Question

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

问题 - 现在我想要的是，在提取中有一个包含值的列（3 - go，4 - Stop，5 - Pause，E - End），所以我只想从提取物中粘贴E-End提取物到其他表。 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

我无法理解您尝试从哪些列获取数据，但以下代码将在满足条件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

Answer 2

这是过滤并提取新列表的列。因此，如果您在该列中有值（3 - 去，4 - 停止，5 - 暂停，E - 结束）。它将创建包含值和标题的工作表。

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

Excel vba代码，用于过滤列中的特定数据并将其粘贴到其他工作表

2 个答案: