Excel VBA代码过滤来自列的特定数据并将其粘贴到其他工作表

大家好 我有一个提取与这么多列，我复制粘贴只需要在其他文件中的列。 我已经为此写了一个下面的代码。

问题 – 现在我想要的，在提取有一列包含价值（3 – 去，4 – 停止，5 – 暂停，E – 结束），所以我想只有电子结束提取粘贴从提取到其他工作表。 9无法编码

请帮助我

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 

Answer 1

这是筛选和提取到新的工作表您的列。 所以如果你有那个列的值（3 – 去，4 – 停止，5 – 暂停，E – 结束）。 它将创build具有值和标题的工作表。

 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