复制范围到一个新的工作表
我正在尝试编写一个macros来复制工作表的不同部分中的一系列数据，并将其粘贴到一个新的工作表。 它应该为工作簿中的每个工作表执行一些指定的例外。 这是我迄今写的代码：
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个不同的范围来从中获取数据。
我已经添加了这个答案，因为它太长，不适合评论。 这不是一个完美的答案，但希望突出几个领域来看看。
- 每个范围参考还包括它正在查看的工作表（省略工作表参考告诉Excel使用当前活动工作表）。
- 一个数组来填充标题。
- SELECT CASE而不是IF
- 如果找不到FIND，请空间做些事情。 你说他们都是一样的，但那是一个完美的世界，我还没有find。
子testing（）
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
结束小组
包括查找最后一个单元格的function：
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
这是我迄今为止…
子testing（）
' 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]来调整填充大小，而不是必须指定行数（本例中为34）。 另外，如何改进代码的其他build议将受到欢迎。 谢谢！