将2个代码与循环组合成1个单独的代码

Question

经过各种试验和错误以及来自这个论坛的帮助，我设法提出以下代码来实现我想要的但它是两个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

感谢您花时间阅读本文。

干杯

Answer 1

另一答案