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

复制特定列而不是整行

1 个答案: