经过各种试验和错误以及来自这个论坛的帮助，我设法提出以下代码来实现我想要的但它是两个vba循环。我遇到了如何将这两个vba与循环组合成1个单独的vba的瓶颈。这是我的代码。
Sub Macro1()
'
' Macro1 Macro
'
Dim WS_Count As Integer
Dim I As Integer
WS_Count = ActiveWorkbook.Worksheets.Count
For I = 1 To WS_Count
Sheets(I).Select
Range("B11").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Range("B11").Select
ActiveCell.FormulaR1C1 = "Outlet name"
Range("C11").Select
ActiveCell.FormulaR1C1 = "PO Number"
Range("D11").Select
ActiveCell.FormulaR1C1 = "PO Date"
Range("E11").Select
ActiveCell.FormulaR1C1 = "Delivery Date"
' Copy outlet name
Range("B1").Select
Selection.Copy
Range("A12").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Select
Range(Selection, Selection.End(xlUp).Offset(1)).Select
ActiveSheet.Paste
' Copy PO number
Range("B2").Select
Selection.Copy
Range("A12").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 2).Select
Range(Selection, Selection.End(xlUp).Offset(1)).Select
ActiveSheet.Paste
' Copy PO date
Range("B3").Select
Selection.Copy
Range("A12").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 3).Select
Range(Selection, Selection.End(xlUp).Offset(1)).Select
ActiveSheet.Paste
' Copy DO date
Range("B4").Select
Selection.Copy
Range("A12").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 4).Select
Range(Selection, Selection.End(xlUp).Offset(1)).Select
ActiveSheet.Paste
Next I
Exit Sub
End Sub
这是第二个vba。
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Sub Marco2()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
Last = LastRow(DestSh)
Set CopyRng = sh.Range("A12").Offset(1).CurrentRegion
Set CopyRng = CopyRng.Offset(1, 0)
Set CopyRng = CopyRng.Resize(CopyRng.Rows.Count - 1)
CopyRng.Copy
'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
'Optional: This will copy the sheet name in the H column
DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value = sh.Name
End If
Next
ExitTheSub:
Application.Goto DestSh.Cells(1)
'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
感谢您花时间阅读本文。
干杯
没有解释，不清楚这段代码应该做什么，但无论如何我都清理了一下。
创建一个单独的过程，以您需要它们运行的顺序运行这两个子。例如：
Sub runMyThings()
Call Macro1
Call Macro2
End Sub
请注意，我将Marco2的名称更改为Macro2，但您应该给它们更有意义的名称。 （否则就像把所有文件都叫做File。）
Option Explicit
Sub Macro1()
Dim i As Integer
For i = 1 To ActiveWorkbook.Worksheets.Count
Sheets(i).Range("B11").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Range("B11").FormulaR1C1 = "Outlet name"
Range("C11").FormulaR1C1 = "PO Number"
Range("D11").FormulaR1C1 = "PO Date"
Range("E11").FormulaR1C1 = "Delivery Date"
' Copy outlet name
Range("B1").Copy
Range("A12").End(xlDown).Offset(0, 1).Select
Range(Selection, Selection.End(xlUp).Offset(1)).Paste
' Copy PO number
Range("B2").Copy
Range("A12").End(xlDown).Offset(0, 2).Select
Range(Selection, Selection.End(xlUp).Offset(1)).Paste
' Copy PO date
Range("B3").Copy
Range("A12").End(xlDown).Offset(0, 3).Select
Range(Selection, Selection.End(xlUp).Offset(1)).Paste
' Copy DO date
Range("B4").Copy
Range("A12").End(xlDown).Offset(0, 4).Select
Range(Selection, Selection.End(xlUp).Offset(1)).Paste
Next i
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Sub Macro2()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
On Error Resume Next 'this will delete the Sheet WITHOUT WARNING.
Application.DisplayAlerts = False
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
Last = LastRow(DestSh)
Set CopyRng = sh.Range("A12").Offset(1).CurrentRegion
Set CopyRng = CopyRng.Offset(1, 0)
Set CopyRng = CopyRng.Resize(CopyRng.Rows.Count - 1)
CopyRng.Copy
'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
'Optional: This will copy the sheet name in the H column
DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value = sh.Name
End If
Next
ExitTheSub:
Application.Goto DestSh.Cells(1)
'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
我不会因为离开这样的代码而感到骄傲，但是如果没有更好地了解你想要做什么，我就不能做更多的事了。 （如果它现在不起作用，请恢复到之前的代码。）
我尝试重构你的代码，以消除大多数select语句，并结合各种偏移量和endup和enddown。 （您应该检查合并结果是否仍然是您所期望的。）
Sub Macro1()
Dim WS_Count As Integer
Dim I As Integer
WS_Count = ActiveWorkbook.Worksheets.Count 'ThisWorkbook (?)
For I = 1 To WS_Count
with Sheets(I)
.Range(.Range("B11"), .Range("B11").End(xlDown).Offset(0,4)).Insert Shift:=xlToRight
.Range("B11").FormulaR1C1 = "Outlet name"
.Range("C11").FormulaR1C1 = "PO Number"
.Range("D11").FormulaR1C1 = "PO Date"
.Range("E11").FormulaR1C1 = "Delivery Date"
' Copy outlet name
.Range("B1").Copy
.Range(.Range("A12").End(xlDown).Offset(0, 1), .Range("A12").Offset(1, 1).End(xlUp)).Paste
' Copy PO number
.Range("B2").Copy
.Range(.Range("A12").End(xlDown).Offset(0, 2), .Range("A12").Offset(1, 2).End(xlUp)).Paste
' Copy PO date
.Range("B3").Copy
.Range(.Range("A12").End(xlDown).Offset(0, 3), .Range("A12").Offset(1, 3).End(xlUp)).Paste
' Copy DO date
.Range("B4").Copy
.Range(.Range("A12").End(xlDown).Offset(0, 4), .Range("A12").Offset(1, 4).End(xlUp)).Paste
end with
Next I
End Sub
我还为以下子添加了一些评论：
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", After:=sh.Range("A1"), Lookat:=xlPart, _
LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
On Error GoTo 0
End Function
Sub Marco2()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Application.DisplayAlerts = False
On Error Resume Next
'If the sheet is always being deleted from the workbook which holds this code, the following line should be:
'ThisWorkbook.Worksheets("RDBMergeSheet").Delete
'That way, if multiple books are open, it won't try to delete from the wrong workbook
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Set DestSh = ActiveWorkbook.Worksheets.Add 'ThisWorkbook (?)
DestSh.Name = "RDBMergeSheet"
For Each sh In ActiveWorkbook.Worksheets 'ThisWorkbook (?)
If sh.Name <> DestSh.Name Then
Last = LastRow(DestSh)
Set CopyRng = sh.Range("A12").Offset(1).CurrentRegion
Set CopyRng = CopyRng.Offset(1, 0).Resize(CopyRng.Rows.Count - 1)
CopyRng.Copy
'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
'Optional: This will copy the sheet name in the H column
DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value = sh.Name
End If
Next sh 'added sh to be more explicit on which loop this is for
ExitTheSub:
Application.Goto DestSh.Cells(1)
'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
回答我注意到两个子循环遍历工作簿中的工作表，因此您应该能够通过从一个工作表循环中获取代码并将其插入另一个工作表中来组合这两个，如下所示：
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", After:=sh.Range("A1"), Lookat:=xlPart, _
LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
On Error GoTo 0
End Function
Sub Marco2()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Application.DisplayAlerts = False
On Error Resume Next
'If the sheet is always being deleted from the workbook which holds this code, the following line should be:
'ThisWorkbook.Worksheets("RDBMergeSheet").Delete
'That way, if multiple books are open, it won't try to delete from the wrong workbook
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Set DestSh = ActiveWorkbook.Worksheets.Add 'ThisWorkbook (?)
DestSh.Name = "RDBMergeSheet"
For Each sh In ActiveWorkbook.Worksheets 'ThisWorkbook (?)
-------------------------------------------------------------
| 'From Macro1
| with sh
| .Range(.Range("B11"), .Range("B11").End(xlDown).Offset(0,4)).Insert Shift:=xlToRight
| .Range("B11").FormulaR1C1 = "Outlet name"
| .Range("C11").FormulaR1C1 = "PO Number"
| .Range("D11").FormulaR1C1 = "PO Date"
| .Range("E11").FormulaR1C1 = "Delivery Date"
|
| ' Copy outlet name
| .Range("B1").Copy
| .Range(.Range("A12").End(xlDown).Offset(0, 1), .Range("A12").Offset(1, 1).End(xlUp)).Paste
|
| ' Copy PO number
| .Range("B2").Copy
| .Range(.Range("A12").End(xlDown).Offset(0, 2), .Range("A12").Offset(1, 2).End(xlUp)).Paste
|
| ' Copy PO date
| .Range("B3").Copy
| .Range(.Range("A12").End(xlDown).Offset(0, 3), .Range("A12").Offset(1, 3).End(xlUp)).Paste
|
| ' Copy DO date
| .Range("B4").Copy
| .Range(.Range("A12").End(xlDown).Offset(0, 4), .Range("A12").Offset(1, 4).End(xlUp)).Paste
| End With
| 'End of from Macro1
----------------------------------------------------------
If sh.Name <> DestSh.Name Then
Last = LastRow(DestSh)
Set CopyRng = sh.Range("A12").Offset(1).CurrentRegion
Set CopyRng = CopyRng.Offset(1, 0).Resize(CopyRng.Rows.Count - 1)
CopyRng.Copy
'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
'Optional: This will copy the sheet name in the H column
DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value = sh.Name
End If
Next sh 'added sh to be more explicit on which loop this is for
ExitTheSub:
Application.Goto DestSh.Cells(1)
'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub