Combine 2 codes with loops into 1 single code - excel

Question

After various trial and errors and helps from this forum, I managed to come out with the following codes to achieve what I want but it's two vba loops. I am hit with bottleneck on how to combine these two vba with loops into 1 single vba.
Here is my code.
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
Here is the second 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
Thank you for your valuable time to read through this.
Cheers

Answer 1

Without explanation, it's unclear what this code is supposed to do, but I cleaned it up a little bit anyhow.
Create a separate procedure to run these two sub's in whichever order you need them to run. For example:
Sub runMyThings()
Call Macro1
Call Macro2
End Sub
Note that I changed the name of Marco2 to Macro2, but you should probably give them more meaningful names than that. (Otherwise it's like having all your files called 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
I'm not proud of leaving the code like this but without a better idea of what you're trying to do, I can't do anything more. (And if it doesn't work now, revert to your previous code.)

Answer 2

I attempted to refactor your code some to eliminate most of the select statements and combine various offsets and endup's and enddown's. (You should check that the combined results are still what you expect.)
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
I added some commentary to the following sub as well:
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
Answer
I noticed that both subs loop through the worksheets in the workbook, so you should be able to combine the two by taking the code from within one sheet-loop and inserting it into the other, like so:
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