Excel VBA will not close my opened workbook - excel

I am pretty much new to VBA and have been trying to learn, with this I have created a code that opens another work book and combines all data to a database file and then copy this to my current open file, the problem I have is that it will not close the workbook and takes a long time doing so. Any ideas please?.
'''
Option Explicit
Sub GasStockReport()
Dim wb As String
Dim st As String
Dim path As String
path = "C:\Users\si2066\OneDrive - ENGIE\Desktop\MP Templates\MP - Stock Control\"
wb = "Gas Stock Take v2"
Workbooks.Open path & wb
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("Database").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Set destsh = ActiveWorkbook.Worksheets.Add
destsh.Name = "Database"
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> destsh.Name Then
Last = GetLastRow(destsh, 1)
With sh
Set CopyRng = sh.Range("A2:K" & GetLastRow(sh, 1))
End With
If Last + CopyRng.Rows.Count > destsh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
Else
CopyRng.Copy IIf(Last = 1, destsh.Cells(1, "b"), destsh.Cells(Last + 1, "b"))
End If
If Last = 1 Then
destsh.Cells(Last, "A").Resize(CopyRng.Rows.Count).Value = sh.Name
Else
destsh.Cells(Last + 1, "A").Resize(CopyRng.Rows.Count).Value = sh.Name
End If
End If
Next
ExitTheSub:
Application.Goto destsh.Cells(1)
destsh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Range("A1").Select
Range(Selection, ActiveCell.End(xlDown).End(xlToRight)).Select
Selection.Copy
ActiveWindow.SelectedSheets.Visible = False
ThisWorkbook.Sheets("Stock History").Activate
Range("N1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.DisplayAlerts = False
On Error Resume Next
Workbooks("Gas Stock Take v2").Close SaveChanges:=True
On Error GoTo 0
Application.DisplayAlerts = True
ThisWorkbook.Sheets("Stock Take").Activate
Call Click
End Sub
Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1)
As Long
With ws
GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
End With
End Function
'''

Your error handling is fine. Using On Error GoTo 0 turns off On Error Resume Next.
I think the issue is the amount of data you're leaving on the clipboard after copy and paste. If you use .copy and .paste always follow that up with Application.CutCopyMode = False

Related

While saving another workbook using VBA saving pop-up showing that workbook file path

When using VBA in master document, I need to copy & paste data from another workbook and save to that workbook. While saving saving pop-up showing file destination path but I don't want other users know the path.
Sub RTS()
ThisWorkbook.Activate
Application.DisplayAlerts = False
Application.ScreenUpdating = False
ActiveSheet.Range("A7:D7", "Q7").Select ActiveSheet.Range("A7:D7,Q7").Select Range("Q7").Activate Application.CutCopyMode = False Selection.Copy
on Error Resume Next While cont Err.Clear Dim wb As Workbook Set wb = Workbooks.Open(Filename:="RTS Report.xlsx") Do Until wb.ReadOnly = False wb.Close Application.Wait Now + TimeValue("00:00:01") Set wb = Workbooks.Open(Filename:="RTS Report.xlsx")
Loop
If Err.Number <> 0 Then Application.Wait (Now + TimeValue("0:00:01")) Err.Clear Else cont = False End If
Wend
On Error GoTo 0
Dim She As Worksheet Dim b As Integer ActiveWorkbook.Sheets("Data").Activate
Set She = ActiveWorkbook.ActiveSheet
b = She.Range("A" & Rows.Count).End(xlUp).Row
She.Range("A" & b + 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone,
SkipBlanks:=False, Transpose:=False
Cells.Select Cells.EntireColumn.AutoFit
ActiveWorkbook.Save ActiveWorkbook.Close ThisWorkbook.Activate Application.ScreenUpdating = True Application.DisplayAlerts = True
End Sub
put before the save string
Application.DisplayAlerts=False
and delete "Application.DisplayAlerts = True"

How to create dynamic ranges and Improving vba Code

I Have a little bit of code (below) that I would like to improve as I find it a little clunky with regards to the ranges as they vary daily, Ideally I would like to use last row instead of using a massive range but, sadly I am not that clever :(
this is the code, if anyone fancies taking a look to improve on I would be greatly appreciative, I think the process is self explanatory (i.e auto filter and copying from one sheet to another)
Sub Refresh_click()
Set DbExtract = ThisWorkbook.Sheets("Sheet1")
Set DuplicateRecords = ThisWorkbook.Sheets("Sheet2")
Sheets("Sheet2").Unprotect
Range("A4:A50").Select
Application.CutCopyMode = False
Selection.ClearContents
Sheets("Sheet1").Select
ActiveSheet.ListObjects("Table22").Range.AutoFilter Field:=23, Criteria1:= _
"="
DbExtract.Range("F2:F99999").SpecialCells(xlCellTypeVisible).Copy
DuplicateRecords.Range("A4:A50").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Sheet2").Protect
Sheets("Sheet1").Select
ActiveSheet.ListObjects("Table22").Range.AutoFilter Field:=23
MsgBox "Log - Updated"
End Sub
Try in this way, please:
Sub Refresh_click()
Dim DbExtract As Worksheet, DuplicateRecords As Worksheet, lastFRow As Long
Set DbExtract = ThisWorkbook.Sheets("Sheet1")
Set DuplicateRecords = ThisWorkbook.Sheets("Sheet2")
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
.CutCopyMode = False
End With
With DuplicateRecords
.Unprotect
.Range("A4:A50").ClearContents
End With
DbExtract.ListObjects("Table22").Range.AutoFilter field:=23, Criteria1:="="
lastFRow = DbExtract.Range("F" & rows.count).End(xlUp).row 'last row of F:F col
DbExtract.Range("F2:F" & lastFRow).SpecialCells(xlCellTypeVisible).Copy
DuplicateRecords.Range("A4").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
DuplicateRecords.Protect
DbExtract.ListObjects("Table22").Range.AutoFilter field:=23
With Application
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.ScreenUpdating = True
End With
MsgBox "Log - Updated"
End Sub
Please, test it and send some feedback. I couldn't test it...
Copy Using AutoFilter
Adjust the values in the constants section.
The Code
Option Explicit
Sub Refresh_click()
Const srcName As String = "Sheet1"
Const srcTblName As String = "Table22"
Const srcCol As Long = 6
Const srcField As Long = 23
Const srcCrit As String = "="
Const dstName As String = "Sheet2"
Const dstFirst As String = "A4"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim cel As Range
Dim rng As Range
Dim Updated As Boolean
With wb.Worksheets(dstName)
.Unprotect
Set cel = .Range(dstFirst)
cel.Resize(cel.Worksheet.Rows.Count - cel.Row + 1).ClearContents
With wb.Worksheets(srcName).ListObjects(srcTblName)
.Range.AutoFilter
Set rng = .ListColumns(srcCol).Range _
.Resize(.ListRows.Count).Offset(1)
'Debug.Print rng.Address
.Range.AutoFilter Field:=srcField, Criteria1:=srcCrit
On Error Resume Next
rng.SpecialCells(xlCellTypeVisible).Copy
On Error GoTo 0
If Application.CutCopyMode = xlCopy Then
cel.PasteSpecial xlPasteValues
Updated = True
End If
.Range.AutoFilter
End With
.Protect
End With
If Updated Then
MsgBox "Log updated.", vbInformation, "Success"
Else
MsgBox "Log not updated.", vbCritical, "Fail"
End If
End Sub

Filter workbook and copy range into another workbook at next available cell

I want to filter workbook by looking for all blank entries in column E. Then copy range into another workbook at the next available row. When I run my code I get an error 'run time error' 1004 - PasteSpecial method of range class failed?? How would I debug this to be able to copy my range and paste into other workbook?
I have only just started learning VBA and learned most of what I know from google and watching youtube videos. I have tried to change the value for blank "", I have tried to add application.cutcopymode false
Sub MoveUnworkedtoDB()
`Dim wbk As Workbook
Dim sh As Worksheet
Dim Lastrow As Long
' Open worksheet 1 and move unworked back to database
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Set wbk = Workbooks.Open(Filename:= _
"Workbook1")
Set sh = wbk.Sheets("sheet1")
'Clear any existing filters
On Error Resume Next
sh.ShowAllData
On Error GoTo 0
'Apply Filter
sh.Range("A1:E9").AutoFilter Field:=5, Criteria1:=""
'copy Range
Application.DisplayAlerts = False
sh.Range("B2:e1000").SpecialCells(xlCellTypeVisible).Copy
Application.DisplayAlerts = True
'Clear Filter
On Error Resume Next
sh.ShowAllData
On Error GoTo 0
Set wbk = Workbooks.Open(Filename:= _
"workbook2")
Set sh = wbk.Sheets("sheet1")
Lastrow = Range("A65536").End(xlUp).row
Sheets("sheet1").Activate
Cells(Lastrow + 1, 1).PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, _
SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
End Sub`
runtime error 1004 - pastespecial method of range class failed
Depends on Excel version. You can't do this in Excel 2003 and older. You transpose 1000 rows to 1000 columns, old Excels have 256 columns only.
I corrected a bit Your code, now will work in newest versions, from 2007 up.
Sub MoveUnworkedtoDB()
Dim wbk As Workbook
Dim sh As Worksheet
Dim Lastrow As Long
Dim wbk2 As Workbook
Dim sh2 As Worksheet
' Open worksheet 1 and move unworked back to database
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Set wbk = Workbooks.Open(Filename:="C:\temp\A.xlsx")
Set sh = wbk.Sheets(1)
'Clear any existing filters
On Error Resume Next
sh.ShowAllData
On Error GoTo 0
'Apply Filter
sh.Range("A1:E9").AutoFilter Field:=5, Criteria1:=""
'copy Range
Application.DisplayAlerts = False
'sh.Range("B2:e1000").SpecialCells(xlCellTypeVisible).Copy
Application.DisplayAlerts = True
'Clear Filter
On Error Resume Next
sh.ShowAllData
On Error GoTo 0
Set wbk2 = Workbooks.Open(Filename:="C:\temp\B.xlsx")
Set sh2 = wbk2.Sheets(1)
With sh2
Lastrow = .Range("A65536").End(xlUp).Row
sh.Range("B2:e1000").SpecialCells(xlCellTypeVisible).Copy
.Cells(Lastrow + 1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
End Sub

Combine 2 codes with loops into 1 single code

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
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.)
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

Combine/Append multiple data worksheets into one summary worksheet and then delete data worksheets

In my workbook I have a FrontPage sheet with a button. This button imports csv files. Each csv file is imported/copied to its own sheet (let's call them data sheets). This part is complete. In the second part I want to combine all these sheets into one summary sheet and then delete all the data sheets. The second part is almost completed. I only need to figure out how to delete the data sheets once they have been combined into the summary sheet.
Thanks!
This is the code so far:
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
Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
Sub CopyDataWithoutHeaders()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim shLast As Long
Dim CopyRng As Range
Dim StartRow As Long
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"
StartRow = 2
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
Last = LastRow(DestSh)
shLast = LastRow(sh)
If shLast > 0 And shLast >= StartRow Then
Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the " & _
"summary worksheet to place the data."
GoTo ExitTheSub
End If
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
End If
End If
Next
ExitTheSub:
Application.Goto DestSh.Cells(1)
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
If you give the sheets convenient names, you can simply loop through all the sheets and delete those called Data[something] for example.
For i = 1 To ActiveWorkbook.Worksheets.Count
If Left(Worksheets(i).Name, 4) = "Data" Then
Application.DisplayAlerts = False
Worksheets(i).Delete
Application.DisplayAlerts = True
End If
Next
Looks like you already have 3/4 of the code (the loop, and name check) going on.
After copying what you need to copy, just add:
Application.DisplayAlerts = False
sh.Delete
Application.DisplayAlerts = True
This deletes the worksheet and removes the requirement for the user to accept / decline the deletion.
Looks like this would go immediately after this block:
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With

Resources