将范围复制到新工作表

时间：2015-11-11 16:48:13

标签： excel vba excel-vba

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

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个不同的范围来获取数据。

2 个答案:

答案 0 :(得分：0)

我已添加此作为答案，因为它太长而无法发表评论。这不是一个完美的答案，但希望强调几个方面要看。

  • 每个范围参考还包括它正在查看的工作表（省略工作表参考告诉Excel使用当前活动工作表）。
  • 用于填充标题的数组。
  • 选择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

End Sub

已包含查找最后一个单元格函数：

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

答案 1 :(得分：0)

这就是我到目前为止......

子测试（）

' 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

End Sub

它的工作原理虽然远非理想的代码。我将不胜感激如何改变这个[wsBudget.Range（＆＃34; F1＆＃34;）。End（xlDown）.Offset（，-5）.End（xlUp）.Offset（1）.Resize（ 34）.PasteSpecial Paste：= xlPasteValuesAndNumberFormats]来调整filldown，而不是必须指定行数（在这种情况下为34）。还欢迎任何其他关于如何改进代码的建议。谢谢！

相关问题
最新问题