コピー特定の列

Question

：

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」をコピーしないようにしたいです。

は、誰かが私の必要性、 - 私わからそのない大したにコードを調整することによって、私を助けてもらえますが、私は

はどうもありがとうございました... VBAのthatsの理由で吸います！

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