复制特定列而不是整行

Question

我创建了以下 vba 代码：

Sub x()

Dim sht As Worksheet, summarySht As Worksheet
Dim rMin As Range, rMax As Range

For Each sht In Worksheets
   If Not sht.Name Like "Summary*" Then
        Set summarySht = Sheets.Add(after:=Sheets(Sheets.Count))
    summarySht.Name = "Summary " & sht.Name
    With sht.Range("F15000:F20000")
        Set rMin = .Find(what:=WorksheetFunction.Min(.Cells), lookat:=xlWhole, LookIn:=xlValues)
        Set rMax = .EntireColumn.Find(what:=WorksheetFunction.Max(.EntireColumn))
        .Parent.Range(rMin, rMax).EntireRow.Copy summarySht.Range("A2")
    End With
End If

我不想复制整行，而只想复制 "B" 和 "G" 列。

Answer 1

我添加了一个新变量只是为了让代码更具可读性。该代码采用所需区域与 B 列和 G 列的交集，并使用 Union 组合它们。

Sub x()

Dim sht As Worksheet, summarySht As Worksheet
Dim rMin As Range, rMax As Range, rOut As Range

For Each sht In Worksheets
    If Not sht.Name Like "Summary*" Then
        Set summarySht = Sheets.Add(after:=Sheets(Sheets.Count))
        summarySht.Name = "Summary " & sht.Name
        With sht.Range("F15000:F20000")
            Set rMin = .Find(what:=WorksheetFunction.Min(.Cells), lookat:=xlWhole, LookIn:=xlValues)
            Set rMax = .EntireColumn.Find(what:=WorksheetFunction.Max(.EntireColumn))
            Set rOut = .Parent.Range(rMin, rMax).EntireRow
            Union(Intersect(rOut, sht.Range("B:B")), Intersect(rOut, sht.Range("G:G"))).Copy summarySht.Range("A2")
        End With
    End If
Next sht

End Sub

复制特定列而不是整行

Copy specific columns instead of entire row

excel

vba

copy-paste