Copy specific columns instead of entire row

Question

I have created the following vba code:

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

I want to not copy the entire row but only columns "B" and "G".

Answer 1

I added a new variable just to make the code a little more readable. The code takes the intersection of the desired region with columns B and G and combines them using 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