Фильтровать, скопировать и вставить цикл с непостоянным расположением столбца в VBA - PullRequest
Новая
       21

Фильтровать, скопировать и вставить цикл с непостоянным расположением столбца в VBA

0 голосов
/ 12 декабря 2018

Мне нужна помощь в составлении некоторого кода в 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

1 Ответ

0 голосов
/ 13 декабря 2018 
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
...