将范围复制到新的工作表

Question

我正在尝试编写一个宏，以从工作表的不同部分复制一系列数据并将其粘贴到新的工作表中。 它应该为工作簿中的每个工作表执行此操作，但有一些指定的例外。 这是我到目前为止编写的代码：

Dim wb As Workbook
Dim ws As Worksheet
Dim Rng As Range

'create new worksheet, name it "Budget"
Set ws = Sheets.Add
ws.Name = "Budget"
'set column titles in the new sheet
Range("A1").Value = "Period"
Range("B1").Value = "Country"
Range("C1").Value = "Product Line"
Range("D1").Value = "Currency"
Range("E1").Value = "Sales"
'search the entire UsedRange of sheet
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "Summary" And ws.Name <> "Template" And ws.Name <> "Data" Then
With ws.UsedRange
    Set Rng = .Find(What:="Product Line", _
                After:=.Cells(.Cells.Count), _
                LookIn:=xlValues, _
                LookAt:=xlWhole, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlNext, _
                MatchCase:=False).Offset(1, 0).Resize(33)
        Sheets("Budget").[F1].End(xlDown).Offset(0, -3).End(xlUp).Offset(1, 0).Resize(Rng.Rows.Count).Value = Rng.Value 'put values from the Find into C column of new sheet
     Set Rng = .Find(What:="201601", _
                After:=.Cells(.Cells.Count), _
                LookIn:=xlValues, _
                LookAt:=xlWhole, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlNext, _
                MatchCase:=False).Offset(1, 0).Resize(33)
        Sheets("Budget").[F1].End(xlDown).Offset(0, -1).End(xlUp).Offset(1, 0).Resize(Rng.Rows.Count).Value = Rng.Value 'put values from the Find into D column of new sheet

End With
End If
Next ws

End Sub

第一部分似乎工作正常，但是当到达第二个“ Set Rng”时，它就再也没有进行了。 我希望设置5个不同的范围来获取数据。

Answer 1

我已经将此添加为答案，因为它太长了，无法放入评论中。 这不是一个完美的答案，但有望突出显示几个方面。

• 每个范围参考还包括它正在查看的工作表（忽略工作表参考会告诉Excel使用当前活动的工作表）。
• 用于填充标题的数组。
• SELECT CASE而不是IF
• 如果找不到FIND，可以做一些事情。 您说它们都是一样的，但是那是一个完美的世界，我还没有发现。

子测试（）

Dim wb As Workbook
Dim ws As Worksheet
Dim wsBudget As Worksheet
Dim Rng As Range
Dim rUsedRange As Range

Set wb = ActiveWorkbook

'create new worksheet, name it "Budget"
Set wsBudget = wb.Sheets.Add
With wsBudget
    .Name = "Budget"
    .Range("A1:E1") = Array("Period", "Country", "Product Line", "Currency", "Sales")
End With

'search the entire UsedRange of sheet.
'ActiveWorkbook or ThisWorkbook?
For Each ws In wb.Worksheets
    Select Case ws.Name
        Case "Summary", "Template", "Data"
            'Do Nothing
        Case Else
            Set rUsedRange = ws.Range(ws.Cells(1, 1), LastCell(ws))
            With rUsedRange
                Set Rng = .Find(What:="Product Line", _
                    After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
                If Not Rng Is Nothing Then
                    Rng.Offset(1, 0).Resize(33).Copy _
                        Destination:=wsBudget.Range("F1").End(xlDown).Offset(, -3).End(xlUp).Offset(1).Resize(Rng.Rows.Count)
                Else
                    'Do something else if Rng not found.
                End If

                Set Rng = .Find(What:=201601, _
                    After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
                If Not Rng Is Nothing Then
                    Rng.Offset(1).Resize(33).Copy _
                        Destination:=wsBudget.Range("F1").End(xlDown).Offset(, -1).End(xlUp).Offset(1).Resize(Rng.Rows.Count)
                Else
                    'Do something if Rng not found.
                End If

            End With
    End Select
Next ws

结束子

包括了查找最后一个单元格的功能：

Public Function LastCell(wrkSht As Worksheet, Optional Col As Long = 0) As Range

    Dim lLastCol As Long, lLastRow As Long

    On Error Resume Next

    With wrkSht
        If Col = 0 Then
            lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
            lLastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
        Else
            lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
            lLastRow = .Columns(Col).Find("*", , , , xlByColumns, xlPrevious).Row
        End If

        If lLastCol = 0 Then lLastCol = 1
        If lLastRow = 0 Then lLastRow = 1

        Set LastCell = wrkSht.Cells(lLastRow, lLastCol)
    End With
    On Error GoTo 0

End Function

Answer 2

这是我到目前为止所拥有的...

子测试（）

' CreateBudgetFormat Macro

Dim wb As Workbook
Dim ws As Worksheet
Dim wsBudget As Worksheet
Dim Rng As Range
Dim rUsedRange As Range

Set wb = ActiveWorkbook

'create new worksheet, name it "Budget"
Set wsBudget = wb.Sheets.Add
With wsBudget
.Name = "Budget"
.Range("A1:E1") = Array("Period", "Country", "Product Line", "Currency", "Sales")
End With

'search the entire UsedRange of sheet.
For Each ws In wb.Worksheets
Select Case ws.Name
    Case "Summary", "Template", "Data"
        'Do Nothing
    Case Else

    For x = 201601 To 201612

        Set rUsedRange = ws.Range(ws.Cells(1, 1), LastCell(ws))
        With rUsedRange
            Set Rng = .Find(What:="Product Line", _
                After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
            If Not Rng Is Nothing Then
                Rng.Offset(1, 0).Resize(32).Copy
                    wsBudget.Range("F1").End(xlDown).Offset(, -3).End(xlUp).Offset(1).Resize(Rng.Rows.Count).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
            Else
                'Do something else if Rng not found.
            End If

            Set Rng = .Find(What:="Product Line", _
                After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
            If Not Rng Is Nothing Then
                Rng.Offset(37, 0).Resize(2).Copy
                    wsBudget.Range("F1").End(xlDown).Offset(, -3).End(xlUp).Offset(1).Resize(Rng.Rows.Count).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
            Else
                'Do something else if Rng not found.
            End If

            Set Rng = .Find(What:=x, _
                After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
            If Not Rng Is Nothing Then
                Rng.Offset(1, 0).Resize(32).Copy
                    wsBudget.Range("F1").End(xlDown).Offset(, -1).End(xlUp).Offset(1).Resize(Rng.Rows.Count).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
            Else
                'Do something if Rng not found.
            End If

            Set Rng = .Find(What:=x, _
                After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
            If Not Rng Is Nothing Then
                Rng.Offset(37, 0).Resize(2).Copy
                    wsBudget.Range("F1").End(xlDown).Offset(, -1).End(xlUp).Offset(1).Resize(Rng.Rows.Count).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
            Else
                'Do something if Rng not found.
            End If

            Set Rng = .Find(What:="Ship_To_Country", _
                After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
            If Not Rng Is Nothing Then
                Rng.Offset(, 1).Copy
                    wsBudget.Range("F1").End(xlDown).Offset(, -4).End(xlUp).Offset(1).Resize(34).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
            Else
                'Do something if Rng not found.
            End If

            Set Rng = .Find(What:=x, _
                After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
            If Not Rng Is Nothing Then
                Rng.Copy
                    wsBudget.Range("F1").End(xlDown).Offset(, -5).End(xlUp).Offset(1).Resize(34).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
            Else
                'Do something if Rng not found.
            End If

        End With
        Next
End Select
Next ws

            With wsBudget
            Range("D2") = "EUR"
            Range("C2").Select
            Selection.End(xlDown).Select
            ActiveCell.Offset(0, 1).Select
            Range(Selection, Selection.End(xlUp)).Select
            Selection.FillDown
            End With

结束子

尽管远非理想的代码，但它仍然有效。 我将对如何更改此[wsBudget.Range（“ F1”）。End（xlDown）.Offset（，-5）.End（xlUp）.Offset（1）.Resize（34）.PasteSpecial Paste）提供任何帮助：= xlPasteValuesAndNumberFormats]来调整filldown的大小，而不必指定行数（在这种情况下为34）。 另外，关于如何改进代码的其他建议也将受到欢迎。 谢谢！