將范圍復制到新的工作表

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）。 另外，關於如何改進代碼的其他建議也將受到歡迎。 謝謝！