Question

我正在寻找有关在VBA中组合一些代码的帮助，这些代码将过滤具有特定标题名称的列，将该信息复制并粘贴到第二张工作表中，然后针对以下内容执行相同的过滤，复制，粘贴操作列中的每个值。不幸的是，列并不总是位于同一位置。

任何帮助将不胜感激。

以下是我到目前为止所获得的：

Dim lastrow As Long
Dim lastcol As Long
Dim SSheet As Worksheet
Dim DSheet As Worksheet
Dim PRange As Range

'Define Data Range
Set SSheet = Worksheets("All Data")
Set DSheet = Worksheets("Data")
lastrow = DSheet.Cells(Rows.Count, 1).End(xlUp).Row
lastcol = DSheet.Cells(1, Columns.Count).End(xlToLeft).Column
Set PRange = DSheet.Cells(1, 1).Resize(lastrow, lastcol)

SSheet.Select
Selection.AutoFilter.Sort.SortFields.Clear
ActiveSheet.ShowAllData
Rows("1:1").Select
Selection.Find(What:="Job Group", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveSheet.Range("$A$1:" & lastrow, lastcol).AutoFilter Field:=14, Criteria1:= _"1A"
Cell ("A1").Select
Range("$A$1:" & lastrow, lastcol).Select
Selection.Copy
DSheet.Select
Range("A1").Select
ActiveCell.Paste
Application.CutCopyMode = False

Answer 1

Sub Button1_Click()
    Dim lastrow As Long
    Dim lastcol As Long
    Dim SSheet As Worksheet, Lst As Long
    Dim DSheet As Worksheet
    Dim PRange As Range, fRng As Range, f As String, c As Range

    f = "Job Group"

    Set SSheet = Worksheets("All Data")
    Set DSheet = Worksheets("Data")

    With SSheet
        Lst = .Cells(.Rows.Count, "A").End(xlUp).Row + 1

        With DSheet
            lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
            lastcol = .Cells(1, .Columns.Count).End(xlToLeft).Column
            Set fRng = .Range(.Cells(1, 1), .Cells(1, lastcol))
            Set c = fRng.Find(what:=f, lookat:=xlWhole)
            Set PRange = .Cells(1, 1).Resize(lastrow, lastcol)
            If .AutoFilterMode Then
                .AutoFilter.Sort.SortFields.Clear
                .AutoFilterMode = False
            End If
            .Range("A1").AutoFilter Field:=c.Column, Criteria1:="1A"
        End With

        PRange.Offset(1).Copy .Cells(Lst, "A")
    End With
End Sub

VBA中具有非恒定列位置的筛选，复制和粘贴循环

1 个答案: