I'm working off of code I found via google. Originally the code was set up to create a new summary sheet, however I'd like to use one that already exists and paste the new data in the next empty row. The issue seems to happen when I set the summary worksheet. I'm getting a "Run-time error '438'" on this line of code -
Set DestSh = ActiveWorkbook.Worksheet("Tab_Upload").Activate
when I use the following code:
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
' Set Summary Worksheet.
Set DestSh = ActiveWorkbook.Worksheet("Tab_Upload").Activate
' Loop through all worksheets and copy the data to the
' summary worksheet.
For Each sh In ActiveWorkbook.Worksheets
If LCase(Left(sh.Name, 1)) = "_" Then
' Find the last row with data on the summary worksheet.
Last = DestSh.[a65536].End(xlUp).Row
' Specify the range to place the data.
Set CopyRng = sh.Rows("A23,B8:S8")
' 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 from each
' worksheet.
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
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
try to change
Set DestSh = ActiveWorkbook.Worksheet("Tab_Upload").Activate
to
Set DestSh = ActiveWorkbook.Worksheets("Tab_Upload")
You have missed s in the end of Worksheets
Related
I need to copy the data from a specific column of all worksheets of an excel file and paste it on to specific sheet with each subjects' name as the first row of the column (which is also the sheet name) and their data underneath that.
The problem is that I get Run-time error '1004':
Application-defined or object-defined error
at the line: targetWs.Cells(2, subColumn).PasteSpecial x1PasteValues
Sub Data()
'
' Data Macro
'assign varaible to subject worksheet and target worksheet
Dim subWs As Worksheet
Dim targetWs As Worksheet
'set subject sheet and target sheet
Set targetWs = ActiveWorkbook.Sheets("Sheet1")
'Loop through all worksheets
'not really sure if I'm doing this right
'Copy subject name; paste to target sheet
Rows(1).Insert
Dim i As Integer
For i = 1 To Sheets.Count
Cells(1, i) = Sheets(i).Name
Next i
'Loop through all worksheets
'not really sure if I'm doing this right
For Each subWs In ThisWorkbook.Worksheets
'Copy subject data; paste to target sheet
subWs.Range("B2:B242").Copy
targetWs.Cells(2, subColumn).PasteSpecial x1PasteValues
subColumn = subColumn + 1
Next subWs
End Sub
As stated in the comment above, I'll try to make it clear what they meant.
First, you have a typo, PasteSpecial x1PasteValues should be PasteSpecial xlPasteValues (it's an "l" not "1").
Second, first time you enter the loop (For Each subWs In ThisWorkbook.Worksheets), since you haven't initialized subColumn to any value, it's 0. so when you try to paste targetWs.Cells(2, subColumn), the first time you enter the loop it's actually targetWs.Cells(2, 0), since there is no column 0, you get this "lovely" run-time error #1004.
Copy a range of each sheet
Note: This example use the function LastRow
This example copy the range A1:G1 from each worksheet.
Change the range in this code line
'Fill in the range that you want to copy
Set CopyRng = sh.Range("A1:G1")
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
https://www.rondebruin.nl/win/s3/win002.htm
I have an Excel workbook which contains lists of sales leads in worksheets, separated out by alphabet (worksheet 'A' contains all leads that start with 'A'). I run the following macro on a separate worksheet to combine all these sheets into one master sheet (code found here).
GOAL: When I change a cell in a worksheet (say worksheet A), I want this to update on the master sheet where my macro is being run. I assume I need to just rerun the macro whenever one of these cells is changed. Is there a way to automatically detect changes in any of the data being utilized by the macro and then triggering it to rerun?
I have found solutions on how to do this to a range of cells or specific cell, but not every cell in a range of worksheets.
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.UsedRange
'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, "M").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
It would be great if it maintained formatting. The cells get resized every time I rerun the macro.
New in VBA and learning on my own.
The intent for the code below is to copy cell "D5" from every sheet in workbook and then paste all the data in workbook "Data", range D4:D300 (the range is pretty broad so it will have more cell available than cells copied). The problem is that the code below is not working. All the code is doing is coping cell D5 from the first sheet over the range indicated (D4:D300). Basically copying the same value 266 times. Any help is highly appreciated.
If there is a more elegant/efficient way to write this code, please advise.
Sub copycell()
Dim sh As Worksheet
Dim wb As Workbook
Dim DestSh As Worksheet
Dim LastRow As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wb = ThisWorkbook
Set DestSh = wb.Sheets("Data")
' Loop through worksheets that start with the name "20"
For Each sh In ActiveWorkbook.Worksheets
' Specify the range to copy the data
sh.Range("D5").Copy
' Paste copied range into "Data" worksheet in Column D
With DestSh.Range("D4:D300")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
Next
End Sub
You don't need to specify an end range -- just 'count' the number of sheets to determine the total # of values you'll need to add to the data tab. Also added in a check to see if you're on the Data worksheet so you don't copy the D5 value from Data again into a row in the same worksheet.
Sub copycell()
Dim sh As Worksheet
Dim wb As Workbook
Dim DestSh As Worksheet
Dim i As Integer
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wb = ThisWorkbook
Set DestSh = wb.Sheets("Data")
' Loop through worksheets that start with the name "20"
i = 4
For Each sh In ActiveWorkbook.Worksheets
If sh.Name = "Data" Then Exit Sub
sh.Range("D5").Copy
With DestSh.Range("d" & i)
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
i = i + 1
Next
End Sub
On each pass through your ActiveWorkbook.Worksheets loop, paste into the cell below the last cell in column D unless D4 is blank, in which case paste in D4. I'm assuming column D is completely blank before running the macro but if D3 has something in it you can do away with the .Range("D4") = "" test.
Sub copycell()
Dim sh As Worksheet
Dim wb As Workbook
Dim DestSh As Worksheet
Dim LastRow As Long
On Error GoTo GracefulExit:
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wb = ThisWorkbook
Set DestSh = wb.Sheets("Data")
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> "Data" Then
sh.Range("D5").Copy
' Paste copied range into "Data" worksheet in Column D
' starting at D4
With DestSh
If .Range("D4") = "" Then
With .Range("D4")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
Else
With .Cells(.Cells(.Rows.Count, 4).End(xlUp).Row + 1, 4)
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
End If
End With
End If
Application.CutCopyMode = False
Next
GracefulExit:
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
If Err <> 0 Then
MsgBox "An unexpected error no. " & Err & ": " _
& Err.Description & " occured!", vbExclamation
End If
End Sub
if you are more concerned about values, then a more concise code could be the following:
Option Explicit
Sub copycell()
Dim sh As Worksheet
Dim iSh As Long
With ThisWorkbook
ReDim dataArr(1 To .Worksheets.Count - 1)
For Each sh In .Worksheets
If sh.Name <> "Data" Then
iSh = iSh + 1
dataArr(iSh) = sh.Range("D5").Value
End If
Next
.Worksheets("Data").Range("D4").Resize(.Worksheets.Count - 1).Value = Application.Transpose(dataArr)
End With
End Sub
where you first store all sheets D5 cell values into an array and then write them in one shot into Data worksheet
This code I have cobbled together for collating content from a named worksheet from all open workbooks seems to run fine on my computer, but not on the clients.
Whats going wrong here? I believe we are running the same version of excel, and using identical workbooks to test with.
It gets stuck on line 22:
wkb.Worksheets(sWksName).Copy _
Before:=ThisWorkbook.Sheets(1)
Sorry I don't have the error message!
Sub CopyandCollateQuery1()
With Application ' Scrubs settings that slow process
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
Dim wkb As Workbook ' Dim Variables
Dim sWksName As String
Dim Title1 As Range
Dim Title1end As Range
Dim NewRng As Range
Dim check As String
sWksName = "Query1" ' Sets Worksheet to be collated
For Each wkb In Workbooks ' Pulls said worksheet title from each open workbook and copies into macro workbook
If wkb.Name <> ThisWorkbook.Name Then
wkb.Worksheets(sWksName).Copy _
Before:=ThisWorkbook.Sheets(1)
End If
Next
Set wkb = Nothing
For Each ws In ThisWorkbook.Worksheets
With ws
If .Name <> "Collated" Then
rowscount = .Cells(ws.Rows.Count, 2).End(xlUp).Row
.Range("B3" & ":" & "B" & rowscount).Copy
Worksheets("Collated").Activate
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False
End If
End With
Next ws
ActiveSheet.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo
If ActiveSheet.Cells(1, 1).Value = "" Then
Rows(1).Delete
ActiveSheet.Cells(1, 2).Value = "Total Combined Count"
End If
ActiveSheet.Cells(1, 1).Activate
For Each ws In ThisWorkbook.Worksheets
With ws
Set lol = ws.Name
If .Name <> "Collated" Then
i = 4
Do While i < rowscount + 1
check = .Range("B" & i).Value
checknum = .Range("B" & i).Offset(0, -1).Value
Sheets("Collated").Activate
Worksheets("Collated").Range("A:A").Find(check, LookAt:=xlWhole).Activate
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = ActiveCell.Value + checknum
checknum = 0
i = i + 1
Loop
End If
End With
Next ws
With Application ' undoes initial processes scrub
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
End With
End Sub
It's also having trouble finding the correct last row when performing the collating action, so I will need to adjust that. But that's beside the point.
As mentioned in your code the For loop For Each wkb In Workbooks is used to Pull said worksheet title from each open workbook and and copy into macro workbook. That means it looks for the sheet Query1 in all the open workbooks and when any of the workbook do not have a sheet named Query1 it throws Subscript out of range error.
You can tackle this error in two ways:
1. Make sure all your workbooks has sheet Query1 (don't think this will always happen)
2. Use error handling in your code
For Each wkb In Workbooks
If wkb.Name <> ThisWorkbook.Name Then
On Error Resume Next '<--- add this line in your code
wkb.Worksheets(sWksName).Copy _
Before:=ThisWorkbook.Sheets(1)
End If
Next
On Error Resume Next resumes execution ignoring any error thrown on the next line of code. Please note that On Error Resume Next does not in any way "fix" the error. It simply instructs VBA to continue as if no error occurred. For details see this link.
Is it possible to copy format of one excel sheet to another worksheet using VBA.
Like manually we can do by selecting entire sheet and then click on format button. And then select other worksheet and format will be copied. Is it possible to do by code.
Thanks & Regards
Sahil Chaudhary
Absolutely. Below is sample code.
see https://msdn.microsoft.com/en-us/library/office/ff837425.aspx
Sub Wsh_PasteSpecial()
Dim WshSrc As Worksheet
Dim WshTrg As Worksheet
Rem Set working worksheets
Set WshSrc = ThisWorkbook.Worksheets("Source")
Set WshTrg = ThisWorkbook.Worksheets("Target")
WshSrc.Cells.Copy
With WshTrg.Cells
.PasteSpecial Paste:=xlPasteColumnWidths
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteFormulasAndNumberFormats
Application.CutCopyMode = False
End With
End Sub
Find below the full code to paste the format of one Worksheet named "Source", including Color, ColumnWidth, RowHeight, Comment, DataValidation, except the contents (Values, Formulas) of the cells to all other Worksheets in the same Workbook excluding a List of Worksheets as an Array
Option Explicit
Sub Wsh_PasteSpecial_Test()
Dim aWshExcluded As Variant, vWshExc As Variant
aWshExcluded = Array("Exclude(1)", "Exclude(2)")
Dim WshSrc As Worksheet
Dim WshTrg As Worksheet
Rem Set Source Worksheet
Set WshSrc = ThisWorkbook.Worksheets("Source")
Application.ScreenUpdating = 0
Rem Process All Worksheets
For Each WshTrg In WshSrc.Parent.Worksheets
Rem Exclude Worksheet Source
If WshTrg.Name <> WshSrc.Name Then
Rem Validate Worksheet vs Exclusion List
For Each vWshExc In aWshExcluded
If WshTrg.Name = vWshExc Then GoTo NEXT_WshTrg
Next
Rem Process Worksheet Target
With WshTrg.Cells
WshSrc.Cells.Copy
.PasteSpecial Paste:=xlPasteFormats 'Source format is pasted.
.PasteSpecial Paste:=xlPasteComments 'Comments are pasted.
.PasteSpecial Paste:=xlPasteValidation 'Validations are pasted.
Application.CutCopyMode = False
Application.Goto .Cells(1), 1
End With: End If:
NEXT_WshTrg:
Next
Application.Goto WshSrc.Cells(1), 1
Application.ScreenUpdating = 1
End Sub