将数据从列和粘贴到其他表格过滤

Question

我有一个带有许多列的提取物。我仅在其他文件中粘贴需要列。

我写了以下代码。

Option Explicit
Private Sub cmdload_Click()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim fn
Dim rcnt As Long
Set wb1 = ActiveWorkbook
Set ws1 = wb1.Sheets("Extract")
ws1.Activate
rcnt = ws1.Range("B2").End(xlDown).Row
ws1.Rows("2" & ":" & rcnt).EntireRow.Delete
ws1.Range("N20000").Value = 1000
0
fn = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*", Title:="Select Extract file")
If fn <> False Then
    Set wb2 = Workbooks.Open(fn)
    Set ws2 = wb2.Sheets("Score data")
    With ws2
        rcnt = .Range("A2").End(xlDown).Row
    End With
Else
    MsgBox "No file selected. Exiting..."
    Exit Sub
End If
ws2.Range("A2:A" & rcnt).Copy
ws1.Range("A2").PasteSpecial xlPasteValues
Application.CutCopyMode = False
ws2.Range("G2:G" & rcnt).Copy
ws1.Range("B2").PasteSpecial xlPasteValues
Application.CutCopyMode = False
ws2.Range("D2:D" & rcnt).Copy
ws1.Range("C2").PasteSpecial xlPasteValues
Application.CutCopyMode = False

在提取物中，有一列包含值（3- go，4-停止，5-暂停，e- end）。

我只想从提取物粘贴到另一张纸。

Answer 1

这是为了过滤并提取到新的列表。因此，如果您在该列中有值（3- GO，4-停止，5-暂停，E- END）。它将创建带有值和标题的表格。

Option Explicit
Private Sub cmdload_Click()
    Dim currRng As Range, dataRng As Range, currCell As Range
    With Worksheets("Sheet1") '<--| change "Sheet1" to your actual worksheet name to filter data in and paste from
        Set currRng = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)) '<--| change to your actual column to filter
        Set dataRng = Intersect(.UsedRange, currRng.EntireRow)
        With .UsedRange
            With .Resize(1, 1).Offset(, .Columns.Count)
                With .Resize(currRng.Rows.Count)
                    .Value = currRng.Value
                    .RemoveDuplicates Array(1), Header:=xlYes
                    For Each currCell In .SpecialCells(xlCellTypeConstants)
                        currRng.AutoFilter field:=1, Criteria1:=currCell.Value
                        If Application.WorksheetFunction.Subtotal(103, currRng) - 1 > 0 Then
                            dataRng.SpecialCells(xlCellTypeVisible).Copy Destination:=GetOrCreateWorksheet(currCell.Value).Range("A1")
                        End If
                    Next currCell
                    .ClearContents
                End With
            End With
        End With
        .AutoFilterMode = False
    End With
End Sub

Function GetOrCreateWorksheet(shtName As String) As Worksheet
    On Error Resume Next
    Set GetOrCreateWorksheet = Worksheets(shtName)
    If GetOrCreateWorksheet Is Nothing Then
        Set GetOrCreateWorksheet = Worksheets.Add(After:=Sheets(Sheets.Count))
        GetOrCreateWorksheet.name = shtName
    End If
End Function

Answer 2

我不明白您要从和获取数据的列，但是下面的代码将在满足标准E-End时复制数据，然后将该数据复制到另一个表列，您将必须自己调整列才能使代码为您工作。

Private Sub cmdload_Click()
Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim fn
Dim x As Range
Dim rcnt As Long
Set ws1 = ActiveWorkbook.Sheets("Extract")
rcnt = ws1.Range("B2").End(xlDown).Row
ws1.Rows("2" & ":" & rcnt).EntireRow.Delete
ws1.Range("N20000").Value = 1000
0
fn = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*", Title:="Select THOR Extract file")
If fn <> False Then
    Set wb2 = Workbooks.Open(fn)
    Set ws2 = wb2.Sheets("Score data")
    With ws2
        rcnt = .Range("A2").End(xlDown).Row
    End With
Else
    MsgBox "No file selected. Exiting..."
    Exit Sub
End If
For Each x In Range("A1").CurrentRegion.SpecialCells(2).Columns(2).Cells
  If x = "E - End" Then
    If Not rng Is Nothing Then Set rng = Union(rng, x) Else Set rng = x
  End If
Next
rng.Copy ws2.Range("A2")
End Sub