Macro pasting start row 4 not 1, headers, and sum total - excel

I have this great macro that creates my sheet and copies and paste information starting in "A1" but I need it to paste starting in "A4" of the new sheet. I plan to add headings in row 1 and totals in row 3. So if you could point me in the right direction to figure that out too it would be great. The amount of rows will vary for the totals.
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 "SUMMARY" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("SUMMARY").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'Add a worksheet with the name "SUMMARY"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "SUMMARY"
'Move the worksheet "SUMMARY"
Sheets("SUMMARY").Select
Sheets("SUMMARY").Move Before:=Sheets(7)
'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, "EnGarde Data", "Service Data", "Usage", "TECHNICIAN", "MASTER", "Dropdown lists"), 0)) 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("F2")
'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
'Copy range to new sheet
CopyRng.Copy DestSh.cells(Last + 1, "B")
'Copy the sheet name in the A column
DestSh.cells(Last + 1, "A").Resize(CopyRng.Rows.Count).Value = sh.Name
'Fill in the range that you want to copy
Set CopyRng = sh.Range("B6")
'Copy range to new sheet
CopyRng.Copy DestSh.cells(Last + 1, "C")
'Fill in the range that you want to copy
Set CopyRng = sh.Range("B4")
'Copy range to new sheet
CopyRng.Copy DestSh.cells(Last + 1, "D")
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

When your macro completed, and all info pasted starting from "A1", you can simply insert the rows before first one. So add this line after ExitTheSub: as many times as as you want blank lines:
DestSh.Rows(1).Insert Shift:=xlDown

Related

Copy paste from multiple sheet to one sheet ( only required multiple columns and set auto filter on consolidated sheet and seprate)

I have three sheets (Sheet1,sheet2 and sheet5)Need to copy from sheet1 column "A","B","E"paste to "Sheet5 "c","G","H" and copy from sheet2 column "J","K", "N" paste to " Sheet5 "c","G","H" (should not overwrite) and Sheet5 i have first three rows are my headers under this it should paste Sheet5 column "G" which has data from sheet1 and sheet2:Need to seperate using autofilter for the specific text "JOhn","Alex","france" only.Separate sheet name should be "JOhn","Alex","france".Need your help on the code:I have tried on below code which is not working for my requirement and am not able to edit because of more conditions( I got from google ) Sub copypaste() Dim lastrow As Integer, erow As Integer, sheet1 As Worksheet, sheet2 As Worksheet Set sheet1 = Worksheets("Sheet1") Set sheet2 = Worksheets("Sheet2") lastrow = sheet1.Cells(Rows.Count, 1).End(xlUp).Row For i = 2 To lastrow erow = sheet2.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row sheet2.Cells(erow, 2) = sheet1.Cells(i, 3) sheet2.Cells(erow, 3) = sheet1.Cells(i, 6) sheet2.Cells(erow, 4) = sheet1.Cells(i, 9) Next i End Sub
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 "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"
'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
'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
See the link below for more details.
https://www.rondebruin.nl/win/s3/win002.htm

Merging Multiple Worksheets To Single Worksheet In Different Workbook

I want to copy all the rows and columns in multiple worksheets in a one workbook to a single worksheet in a different workbook. In addition, I just want to copy the header once, even though it is in all of the worksheets I'll copy.
I can open the workbook containing all of the worksheets I want to copy to my destination worksheet/workbook however, I don't know how to copy the header only once and often get a Paste Special error.
Sub Raw_Report_Import()
'Define variables'
Dim ws As Worksheet
Dim wsDest As Worksheet
'Set target destination'
Set wsDest = Sheets("Touchdown")
'For loop to copy all data except headers'
For Each ws In ActiveWorkbook.Sheets
'Ensure worksheet name and destination tab do not have same name'
If ws.Name <> wsDest.Name Then
ws.Range("A2", ws.Range("A2").End(xlToRight).End(xlDown)).Copy
wsDest.Cells(Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteValues
End If
Next ws
End Sub
Expected: All of the target worksheets from second workbook are copied and pasted to destination worksheet "Touchdown" in first workbook and the header is copied only once.
Actual: Some values are paste but the formatting is wrong from what they were and it is not lining up correctly.
There are a number of things wrong with your code. Please find below code (not tested). Please note the differences so you can improve.
Note, when setting the destination worksheet, I would include the workbook object (if in a different workbook). This will prevent errors from occurring. Also note that this code should be run in the OLD workbook. Additionally, I assume your headers are in Row 1 in each sheet, as such I have included headerCnt to take this into consideration and only copy the headers once.
Option Explicit
Sub Raw_Report_Import()
Dim ws As Worksheet
Dim wsDest As Worksheet
Dim lCol As Long, lRow As Long, lRowTarget As Long
Dim headerCnt As Long
'i would include the workbook object here
Set wsDest = Workbooks("NewWorkbook.xlsx").Sheets("Touchdown")
For Each ws In ThisWorkbook.Worksheets
'this loops through ALL other sheets that do not have touch down name
If ws.Name <> wsDest.Name Then
'need to include counter to not include the header
'establish the last row & column to copy
lCol = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column
lRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
'establish the last row in target sheet
lRowTarget = wsDest.Range("A" & wsDest.Rows.Count).End(xlUp).Row + 1
If headerCnt = 0 Then
'copy from Row 1
ws.Range(ws.Cells(1, 1), ws.Cells(lRow, lCol)).Copy
Else
'copy from row 2
ws.Range(ws.Cells(2, 1), ws.Cells(lRow, lCol)).Copy
End If
wsDest.Range("A" & lRowTarget).PasteSpecial xlPasteValues
'clear clipboard
Application.CutCopyMode = False
'header cnt
headerCnt = 1
End If
Next ws
End Sub
Try it like this.
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 "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"
'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
'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
All details are here.
https://www.rondebruin.nl/win/s3/win002.htm

Copy specified columns to a worksheet based on value in column A

I have the following which works ok but instead of copying the entire row from the "Combined" worksheet to the "Summary" worksheet I only want to copy columns A to T. This is a first attempt so any help would be gratefully received!
`Private Sub CommandButton1_Click()
'Define Variables
Dim DestSh As Worksheet
Dim s As Worksheet
Dim c As Integer
Dim i
Dim LastRow
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Delete the Combined sheet if it exists
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("Combined").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'Add a new Combined worksheet
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Combined"
'Select Summary worksheet and copy headings and column widths to Combined worksheet
Sheets("Summary").Activate
Range("A24").EntireRow.Select
Selection.Copy Destination:=Sheets("Combined").Range("A1")
For c = 1 To Sheets("Summary").Columns.Count
Sheets("Combined").Columns(c).ColumnWidth = Sheets("Summary").Columns(c).ColumnWidth
Next
'Loop through all worksheets sheets that begin with ra
'and copy to the combined worksheet
For Each s In ActiveWorkbook.Sheets
If LCase(Left(s.Name, 2)) = "ra" Then
Application.Goto Sheets(s.Name).[A1]
Selection.Range("A23:Q50").Select
Selection.Copy Destination:=Sheets("Combined"). _
Cells(Rows.Count, 1).End(xlUp)(2)
End If
Next
'Copy all rows that contain Yes in column A to Summary worksheet
LastRow = Sheets("Combined").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Summary").Range("A25:V500").ClearContents
For i = 1 To LastRow
If Sheets("Combined").Cells(i, "A").Value = "Yes" Then
Sheets("Combined").Cells(i, "A").EntireRow.Copy Destination:=Sheets("Summary").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next i
'Force return to Summary worksheet
Worksheets("Summary").Activate
End Sub
You can use the .Resize() method to change the range that is copied. Replace your line where you copy and paste it to the new destination with this one and it should work:
Sheets("Combined").Cells(i, "A").Resize(1, 20).Copy Destination:=Sheets("Summary").Range("A" & Rows.Count).End(xlUp).Offset(1)

Copy range from sheet overwrites data

I am writing a macro to copy a range from multiple sheets (within the same workbook) to a column in a new sheet in the workbook. I would like values in the range ("C2:C12021") from the first sheet to be copied to column A in the new sheet, then values in the range ("C2:C12021") from the second sheet to column B in the new sheet and so on.
I am currently using the following code however the macro keeps copying the range from each of the sheets I am trying to combine to the same column of the sheet where I am trying to combine them.
As such only the range from the last sheet appears in the combined sheet, I presume this is where the range copied from the other sheets has simply been overwritten as the macro loops through the sheets.
Sub CombineWorksheets()
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("MergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'Add a worksheet named "MergeSheet"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "MergeSheet"
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
'Copy target range
Set CopyRng = sh.Range("C2:C12021")
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
End If
Next
End Sub
You can reference the horizontal values of cells as integers, i.e.
.Cells(Vertical As Integer, Horizontal As Integer)
So at the start of the loop, have a counter variable, and use that in the horizontal value.
Dim count As Integer
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
count = count + 1
'Copy target range
Set CopyRng = sh.Range("C2:C12021")
CopyRng.Copy
With DestSh.Cells(last + 1, count)
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
End If
Next

VBA Code error in copying data from multiple WS to consolidated sheet

I wanted to copy the data from multiple sheets to a single sheet. Data range in multiple sheets keep varying, so I will have to copy whatever data is in the WS and paste it to the consolidated WS. My VBA Code is giving me an error stating, compilation error "Expected Array" at "Last = LastRow(DestSh)". Can someone please help me how to correct this?
Sub Consolidatedata()
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 LastRow As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
' Delete the summary sheet if it exists.
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("Consolidated").Delete
On Error GoTo 0
Application.DisplayAlerts = True
' Add a new summary worksheet.
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Consolidated"
' Fill in the start row.
StartRow = 2
' Loop through all worksheets and copy the data to the
' summary worksheet.
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
' Find the last row with data on the summary
' and source worksheets.
Last = LastRow(DestSh)
shLast = LastRow(sh)
' If source worksheet is not empty and if the last
' row >= StartRow, copy the range.
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 to see whether there are enough rows in the summary
' worksheet to copy all the data.
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
' This statement copies values and formats.
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 summary sheet.
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
LastRow is declared as a Long around line 8 in the code supplied. So it just has a numerical value, which defaults to zero.
I'm guessing you may also have a LastRow function, probably looking something like this?
Function LastRow(sh As WorkSheet) As Long
Try removing this line:
Dim LastRow As Long

Resources