Question

我在“Sheet2”上有一个预定的列标题列表。我想写一个宏来循环这些并在“Sheet1”上搜索匹配的col标题并将它们粘贴到“Sheet3”上。

非常感谢：）

到目前为止，我已经提出了以下建议：

Sub cppp() 
Range("K2").Select Selection.AutoFill Destination:=Range("K2:K10"), Type:=xlFillDefault     

Dim lr As Long, i As Long 
lr = Range("K2").End(xlDown).Row 

For i = lr To 1 Step -1 
    If Cells(lr, 11).Value = Range("A2") Then 'STUCK 
    End If
    lr = lr - 1 
Next i 
End Sub

Answer 1

看看这是否适合你

Sub sample()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim sh3 As Worksheet
Dim rngLookupValues As Range
Dim rngHeaders As Range
Dim cValue As Range
Dim rngCellsToCopy As Range
Dim lngColumnToCopy As Long
Dim lngCurFirstEmptyColumn As Long

Set sh1 = Sheets("Sheet1")
Set sh2 = Sheets("Sheet2")
Set sh3 = Sheets("Sheet3")
With sh2
    Set rngLookupValues = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
End With

With sh1
    Set rngHeaders = .Range("A1", .Range("A1").End(xlToRight))
End With

For Each cValue In rngLookupValues
    lngColumnToCopy = WorksheetFunction.Match(cValue, rngHeaders, 0)

    With sh1
        Set rngCellsToCopy = .Range(.Cells(1, lngColumnToCopy), .Cells(Rows.Count, lngColumnToCopy).End(xlUp))
    End With

    With sh3
        lngCurFirstEmptyColumn = .Cells(1, Columns.Count).End(xlToLeft).Column + 1
    End With

    sh3.Cells(1, lngCurFirstEmptyColumn).Resize(rngCellsToCopy.Rows.Count).Value = rngCellsToCopy.Value
Next cValue

With sh3.Range("A1")
    If Len(.Value) < 1 Then
        .EntireColumn.Delete
    End If
End With
End Sub

根据另一页上的列表复制和粘贴特定列

1 个答案: