Merging sheets in to a master sheet - excel

I got the following code from Ron de Bruin's site and it works pretty much fine for pulling data into a master sheet, and updating the master sheet whenever there are changes in the other sheets.
But I would like to copy only certain columns of data. For example my sheets have data from A:Z but i only need the A:P data in my master sheet.
Any help on this will be greatly appreciated and please know that im a non-coder, so please be specific about what to change and where to change it.
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
'Delete the sheet "Master Sheet" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("Master Sheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'Add a worksheet with the name "Master Sheet"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Master Sheet"
'Fill in the start row
StartRow = 2
'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
'Copy header row, change the range if you use more columns
If WorksheetFunction.CountA(DestSh.UsedRange) = 0 Then
sh.Range("A1:Z1").Copy DestSh.Range("A1")
End If
'Find the last row with data on the DestSh and sh
Last = LastRow(DestSh)
shLast = LastRow(sh)
'If sh is not empty and if the last row >= StartRow copy the CopyRng
If shLast > 0 And shLast >= StartRow Then
'Set the range that you want to copy
Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))
'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
'This example copies values/formats, if you only want to copy the
'values or want to copy everything look below example 1 on this page
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)
'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
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

Actually you just have to change the code that defines the area that should be copied. In your case you have to check the "ranges" before copying the data:
sh.Range("A1:Z1").Copy DestSh.Range("A1")
That line takes care of the headlines, so you can replace the Z1 with e. g. P1.
The next range is to copy the data:
Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))
Here you can use the existing functionality to get the correct start row and last row. But instead of selecting the complete rows you will just select a part of the sheet:
sh.Range("A" & StartRow & ":P" & shLast)
That should do the trick.
P. S. Even If you are not a programmer. Have a look at the VBA Basics, its not that hard and you can do a lot of cool stuff if you know how it works... :)

Related

VBA code to combine two Workbooks into one Worksheet

I want to know if it is possible to bring two workbooks (sheet1) into one worksheet (master workbook). I need to have two data together in one worksheet.
Any help is really appreciated. Below are screenshots for further details if helps.
Two files:
Fundraise-pages(1).csv
Supporters(1).csv
Please see the attached for further details if help?
Thank you for looking into this.
File 1 and File 2 data - both have the same email addresses.
Importantly I would like a macro to pull data to identify or even match for both email addresses. If found then add it onto a worksheet.
For example on the worksheet (master) there should be a data file 1 on the left hand side and the data file 2 on the right hand side including headings.
I hope you can see my images clearly?
Regards
V
enter image description here
enter image description here
Here is an overview to start with:
https://support.microsoft.com/en-us/office/import-or-export-text-txt-or-csv-files-5250ac4c-663c-47ce-937b-339e391393ba
Vba Import CSV files to Excel
Proposal:
Using the connection via PowerQuery allows you to further process them as tables and also join/merge them into one while you can see and follow each step of the process.
Something like this should do what you want. Feel free to change the code to suit your needs.
Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Delete the sheet "RDBMergeSheet" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'Add a worksheet with the name "RDBMergeSheet"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"
'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
'Find the last row with data on the DestSh
Last = LastRow(DestSh)
'Fill in the range that you want to copy
Set CopyRng = sh.Range("A1:G1")
'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
'This example copies values/formats, if you only want to copy the
'values or want to copy everything look at the example below this macro
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
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
Source code:
https://www.rondebruin.nl/win/s3/win002.htm
Also, check this out.
https://www.rondebruin.nl/win/addins/rdbmerge.htm

How to create multiple excel sheets from single sheet based on column data or using pivot

I have an excel sheet which has consolidated yearly data .
For eg : each year 2014 , 2015 , 2016 has multiple rows
I need to split this data and create one sheet for each year and the name of the sheet should be the year.
What I did was to create a pivot by year and click on the count . It would create a new sheet only for that year and then I change the name of the sheet to the year
Is there any simple way of doing it ? I have to do this for many excels and I am manually creating a pivot and clicking on each count cell .
Let me know if there is any automated way of achieving this using VB script or to click all counts at once in a pivot table so that multiple sheets can get generated
Try it this way.
Sub Copy_To_Worksheets()
'Note: This macro use the function LastRow
Dim My_Range As Range
Dim FieldNum As Long
Dim CalcMode As Long
Dim ViewMode As Long
Dim ws2 As Worksheet
Dim Lrow As Long
Dim cell As Range
Dim CCount As Long
Dim WSNew As Worksheet
Dim ErrNum As Long
'Set filter range on ActiveSheet: A1 is the top left cell of your filter range
'and the header of the first column, D is the last column in the filter range.
'You can also add the sheet name to the code like this :
'Worksheets("Sheet1").Range("A1:D" & LastRow(Worksheets("Sheet1")))
'No need that the sheet is active then when you run the macro when you use this.
Set My_Range = Range("A1:D" & LastRow(ActiveSheet))
My_Range.Parent.Select
If ActiveWorkbook.ProtectStructure = True Or _
My_Range.Parent.ProtectContents = True Then
MsgBox "Sorry, not working when the workbook or worksheet is protected", _
vbOKOnly, "Copy to new worksheet"
Exit Sub
End If
'This example filters on the first column in the range(change the field if needed)
'In this case the range starts in A so Field:=1 is column A, 2 = column B, ......
FieldNum = 1
'Turn off AutoFilter
My_Range.Parent.AutoFilterMode = False
'Change ScreenUpdating, Calculation, EnableEvents, ....
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
ActiveSheet.DisplayPageBreaks = False
'Add a worksheet to copy the a unique list and add the CriteriaRange
Set ws2 = Worksheets.Add
With ws2
'first we copy the Unique data from the filter field to ws2
My_Range.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("A1"), Unique:=True
'loop through the unique list in ws2 and filter/copy to a new sheet
Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
For Each cell In .Range("A2:A" & Lrow)
'Filter the range
My_Range.AutoFilter Field:=FieldNum, Criteria1:="=" & _
Replace(Replace(Replace(cell.Value, "~", "~~"), "*", "~*"), "?", "~?")
'Check if there are no more then 8192 areas(limit of areas)
CCount = 0
On Error Resume Next
CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible) _
.Areas(1).Cells.Count
On Error GoTo 0
If CCount = 0 Then
MsgBox "There are more than 8192 areas for the value : " & cell.Value _
& vbNewLine & "It is not possible to copy the visible data." _
& vbNewLine & "Tip: Sort your data before you use this macro.", _
vbOKOnly, "Split in worksheets"
Else
'Add a new worksheet
Set WSNew = Worksheets.Add(After:=Sheets(Sheets.Count))
On Error Resume Next
WSNew.Name = cell.Value
If Err.Number > 0 Then
ErrNum = ErrNum + 1
WSNew.Name = "Error_" & Format(ErrNum, "0000")
Err.Clear
End If
On Error GoTo 0
'Copy the visible data to the new worksheet
My_Range.SpecialCells(xlCellTypeVisible).Copy
With WSNew.Range("A1")
' Paste:=8 will copy the columnwidth in Excel 2000 and higher
' Remove this line if you use Excel 97
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
.Select
End With
End If
'Show all data in the range
My_Range.AutoFilter Field:=FieldNum
Next cell
'Delete the ws2 sheet
On Error Resume Next
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
On Error GoTo 0
End With
'Turn off AutoFilter
My_Range.Parent.AutoFilterMode = False
If ErrNum > 0 Then
MsgBox "Rename every WorkSheet name that start with ""Error_"" manually" _
& vbNewLine & "There are characters in the name that are not allowed" _
& vbNewLine & "in a sheet name or the worksheet already exist."
End If
'Restore ScreenUpdating, Calculation, EnableEvents, ....
My_Range.Parent.Select
ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
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:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Before:
After:

Copy multiple sheets in a workbook to a summary sheet based on autofilter criteria

I have a code that is not working in copying data from multiple sheets into a single one based on autofilter criteria.
I have this code and it is copying the data from different sheets but on applying autofilter condition it stops working
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
Dim WSNew As Worksheet
Dim MyRange As Range
Dim my_range As Range
Dim Rng As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Add a worksheet
'Set DestSh = ActiveWorkbook.Worksheets.Add
Set DestSh = ActiveWorkbook.Worksheets("Sheet16")
'DestSh.Name = "Destination"
'Fill in the start row
StartRow = 2
'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If IsError(Application.Match(sh.Name, _
Array(DestSh.Name, "Format", "Lookups"), 0)) And sh.Visible = True Then
'Find the last row with data on the DestSh and sh
Last = LastRow(DestSh)
shLast = LastRow(sh)
MsgBox sh.Name
Set my_range = Range("A1:ZZ" & LastRow(ActiveSheet))
my_range.Parent.Select
'If sh is not empty and if the last row >= StartRow copy the CopyRng
If shLast >= StartRow Then
my_range.Parent.AutoFilterMode = False
ActiveSheet.Range("A1").AutoFilter Field:=22, Criteria1:="=Ready to import"
'ActiveSheet.AutoFilter.Range.Offset(1, 0).Rows.SpecialCells(xlCellTypeVisible).Copy
With my_range.Parent.AutoFilter.Range
Set Rng = .Offset(1, 0).Resize(.Rows.Count, .Columns.Count) _
.SpecialCells(xlCellTypeVisible)
MsgBox my_range
If Not Rng Is Nothing Then
'Copy and paste the cells into DestSh below the existing data
Rng.Copy
With DestSh.Range("A" & LastRow(DestSh) + 1)
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
End If
' Intersect(.UsedRange, .UsedRange.Offset(1)).SpecialCells(xlCellTypeVisible).Copy
' DestSh.Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
MsgBox Last
' With DestSh.Cells(Last + 1, "A")
' .PasteSpecial Paste:=8
' .PasteSpecial xlPasteValues
' .PasteSpecial xlPasteFormats
' Application.CutCopyMode = False
' .Select
' End With
' End If
'Close AutoFilter
my_range.Parent.AutoFilterMode = False
'Set the range that you want to copy
' Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))
'Test if there enough rows in the DestSh to copy all the data
' If Last + MyRange.Rows.Count > DestSh.Rows.Count Then
' MsgBox "There are not enough rows in the Destsh"
' GoTo ExitTheSub
' End If
'This example copies values/formats, if you only want to copy the
'values or want to copy everything look below example 1 on this page
' CopyRng.Copy
' With DestSh.Cells(Last + 1, "A")
' .PasteSpecial xlPasteValues
' .PasteSpecial xlPasteFormats
' Application.CutCopyMode = False
End With
End If
'End If
'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
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
The sheets should be copied one below another if they match the criteria.
This is basic code does what you are trying to accomplish.
Sub CopyDataWithoutHeaders()
Dim ws As Worksheet, DestSh As Worksheet, Rng As Range
Set DestSh = ThisWorkbook.Sheets("Sheet16")
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
For Each ws In ThisWorkbook.Sheets
If ws.Name <> "Format" And ws.Name <> "Lookups" And ws.Name <> DestSh.Name Then
'the below line will not select the complete range if a cell is empty in column 1
'it can be changed to the way you want.
Set Rng = ws.Range("A1", ws.Range("A1").End(xlDown).End(xlToRight))
With Rng 'will copy all the range except the header row
.AutoFilter Field:=22, Criteria1:="Ready to import", Operator:=xlAnd
.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy
End With
'test if the first cell is empty before pasting
If DestSh.Range("A1") = "" Then
DestSh.Cells(Rows.Count, "A").End(xlUp).PasteSpecial xlPasteValues
Else: DestSh.Cells(Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteValues
End If
End If
'clean up each worksheet
ws.AutoFilterMode = False
Application.CutCopyMode = False
Next ws
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Thank you for the help
Issue Solved
Sub CopyDataWithoutHeaders()
Dim ws As Worksheet, DestSh As Worksheet, Rng As Range
Set DestSh = ThisWorkbook.Sheets("All")
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
For Each ws In ThisWorkbook.Sheets
If ws.Name <> "Format" And ws.Name <> "Lookups" And ws.Name <> DestSh.Name Then
Set Rng = ws.UsedRange
With Rng 'will copy all the range except the header row
.AutoFilter Field:=22, Criteria1:="Ready to import", Operator:=xlAnd
***If (ws.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count > 1)*** Then
.Offset(1, 0).Resize(Rng.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy
DestSh.Cells(Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteValues
End If
End With
End If
'clean up each worksheet
ws.AutoFilterMode = False
Application.CutCopyMode = False
Next ws
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

VBA code has too many loops which makes it run slower

I have a VBA code which copies same data from Multiple sheet and then paste it in "Main" Sheet. It then auto fills the blank cells for values from above and then it delete all the rows Where H:H is blank. However being novice in VBA, i feel my code has too many loops, which makes it run slower. Moreover if have the "Main" Sheet have a table formatted, the code does not delete any row H is blank. However it works if "Main" is blank and not formatted.
Another thing I found out that after the code is executed, the excel sheet becomes less responsive. I cannot select cells quickly, change between sheets.
Please advise if anything can be improved to make it run more efficiently.
Private Sub CopyRangeFromMultiWorksheets1()
'Fill in the range that you want to copy
'Set CopyRng = sh.Range("A1:G1")
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim rng As Range
Dim Last As Long
Dim CopyRng1 As Range
Dim CopyRng2 As Range
Dim CopyRng3 As Range
Dim CopyRng4 As Range
Dim CopyRng5 As Range
Dim CopyRng6 As Range
Dim CopyRng7 As Range
Dim cell As Range
Dim Row As Range
Dim LastrowDelete As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Delete the sheet "RDBMergeSheet" if it exist
'Application.DisplayAlerts = False
On Error Resume Next
'ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
'Application.DisplayAlerts = True
'Add a worksheet with the name "RDBMergeSheet"
Set DestSh = Sheets("Main")
'Set DestSh = ActiveWorkbook.Worksheets.Add
' DestSh.Name = "RDBMergeSheet"
'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name And sh.Name <> "PAYPERIOD" And sh.Name <>
"TECHTeamList" Then
'Find the last row with data on the DestSh
Last = LastRow(DestSh)
'Fill in the range that you want to copy
Set CopyRng1 = sh.Range("B3")
Set CopyRng2 = sh.Range("C3")
Set CopyRng3 = sh.Range("D3")
Set CopyRng4 = sh.Range("G3")
Set CopyRng5 = sh.Range("C5")
Set CopyRng6 = sh.Range("A8:j25")
Set CopyRng7 = sh.Range("A28:j45")
'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng1.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If
'This example copies values/formats, if you only want to copy the
'values or want to copy everything look at the example below this
macro
CopyRng1.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
CopyRng2.Copy
With DestSh.Cells(Last + 1, "B")
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
CopyRng3.Copy
With DestSh.Cells(Last + 1, "C")
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
CopyRng4.Copy
With DestSh.Cells(Last + 1, "D")
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
CopyRng5.Copy
With DestSh.Cells(Last + 1, "E")
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
CopyRng6.Copy
With DestSh.Cells(Last + 1, "F")
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
End With
'Refresh the Lastrow used so that the values start from
'underneath copyrng6
Last = LastRow(DestSh)
CopyRng7.Copy
With DestSh.Cells(Last + 1, "F")
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
End With
End If
Next
ExitTheSub:
Application.Goto DestSh.Cells(1)
'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit
'Autofill the rang A2:E for values from above looking at the last row of F
With Range("A2:E" & Range("F" & Rows.Count).End(xlUp).Row)
.SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
.Value = .Value
End With
'Delete Entire rows where H is Blank
Application.ScreenUpdating = False
Columns("H:H").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True
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
Any Help would be appreciated.

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