Excel 复制特定列而不是整行

我创建了以下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”。

我添加了一个新变量，只是为了让代码更具可读性。该代码获取所需区域与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