I have a Macro however it doesnt seem to be working. I have a workbook which has multipul worksheets. I basically want to copy cells B1, G1, M94 all to a seperate "Summary" worksheet. Copied Cells to go to A4 B4 and C4 than if there is more A5, B5 and C5 and so on.
The coding i have is below. I have tried to make it so it only did it for one sheet but need it for about 10 sheets all with different names.
Sub SummurizeSheets()
Dim ws As Worksheet
Application.ScreenUpdating = False
Sheets("Summary").Activate
For Each ws In Worksheets
If ws.Name <> "17B CUNNINGHAM" Then
ws.Range("B1, G1, M94").Copy
Worksheets("Summary").Cells(Rows.Count, 3).End(xlUp).Offset(1, 0) _
.PasteSpecial (xlPasteValues)
End If
Next ws
End Sub
The problem you will have is you cannot copy/ paste a range the way you have tried to (multiple sections).This should work:
Sub SummurizeSheets()
Dim ws As Worksheet, wsSummary As Worksheet
Dim c As Range
Application.ScreenUpdating = False
Set wsSummary = Sheets("Summary")
' Set destination cell
Set c = wsSummary.Range("A4")
For Each ws In Worksheets
If ws.Name <> "17B CUNNINGHAM" And ws.Name <> "Summary" Then
ws.Range("B1").Copy
c.PasteSpecial (xlPasteValues)
ws.Range("G1").Copy
c.Offset(0, 1).PasteSpecial (xlPasteValues)
ws.Range("M94").Copy
c.Offset(0, 2).PasteSpecial (xlPasteValues)
' Move destination cell one row down
Set c = c.Offset(1, 0)
End If
Next ws
Application.ScreenUpdating = True
End Sub
I have used a destination cell to place the paste which you can then offset for the next row so you can use this for multiple sheets. Also excluded the Summary sheet from the For Each and reset the ScreenUpdating
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
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
Our office has recently updated to excel 2013 and a code which worked in the 2010 version is not working. I've searched on several threads here on SO and have yet to find a solution that works for this particular case.
The code identifies and copies a range of cells from an open workbook and logs them into a second workbook, one range of cells at a time. The reason it's set up to copy only 1 row at a time is because the number of rows to be copied varies from time to time. Since the change to 2013, the Selection.PasteSpecial functions have been triggering the debug prompt.
In practice, the worksheet is being used as a routing form. Once it's filled out, we run the code and save all the relevant information in a separate workbook. Since it's a routing form, the number of people on it varies, and we need a row for each person in order to track their 'status'.
The code:
Sub Submit()
'Transfer code
Dim i As Long, r As Range, coltoSearch As String
coltoSearch = "I"
'Change i = # to transfer rows of data. Needs to be the first row which copies over.
'This is to identify how many rows are to be copied over. If statement ends the for loop once an "empty" cell is reached
For i = 50 To Range(coltoSearch & Rows.Count).End(xlUp).Row
Set r = Range(coltoSearch & i)
If Len(r.Value) = 0 Then
Exit For
End If
'Copies the next row on the loop
Range(Cells(i, 1), Cells(i, 18)).Copy
'open the workbook where row will be copied to
Workbooks.Open FileName:= _
"Workbook2"
'definition for the first empty row in Workbook 2, or the row under the last occupied cell in the Log
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
'selects the first cell in the empty row
ActiveSheet.Cells(erow, 1).Select
' Pastes the copied row from Workbook 1 into Workbook 2. First line is highlighted when debugging
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.CutCopyMode = False
'moves to the next row
Next i
Any thoughts? I'm open to all options. Thanks for your time.
The Working alternative to select is
ActiveSheet.Cells(erow, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
but just for be sure that everything is going fine you have to set the range where i you want to paste everything
dim rngToFill as range
Set rngToFill = ActiveSheet.Cells(erow, 1)
maybe instead of using ActiveSheet you have to define that sheet after opening the wb with
dim wb as Workbook, ws as worksheet
set wb = Workbooks.Open FileName:="Workbook2"
set ws = wb.Sheets(nameofthesheet) 'or number of the sheet
then
set rngToFill = ws.Cells(erow, 1)
then you can paste in that range using .PasteSpecial method, but before doing that, try to be sure that there is no merged cell and that the worksheet we're you are going to paste values is not protected.
rngToFill.PasteSpecial xlPasteValuesAndNumberFormats
Your code:
dim wb as Workbook, ws as worksheet
set wb = Workbooks.Open(FileName:="Workbook2")
set ws = wb.Sheets(nameofthesheet) 'or number of the sheet
erow = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
if erow = 0 then erow = 1
set rngToFill = ws.Cells(erow, 1)
rngToFill.PasteSpecial xlPasteValuesAndNumberFormats
The B plan is to use a for loop iterating throug the cell you want to copy... but it's painfull slowly!
Dim wb As Workbook, newWs As Worksheet, oldWs As Worksheet
Dim z As Integer
Set oldWs = ActiveSheet
Set wb = Workbooks.Open("Workbook2")
Set newWs = wb.Sheets(1)
erow = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
If erow = 0 Then erow = 1
For z = 1 To 18
newWs.Cells(erow, z) = oldWs.Cells(i, z).Value
Next z
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.CutCopyMode = False
'moves to the next row
Next i
I want to copy my data of "Sheet 1" and "sheet 2" to "sheet 3"
I have the following code
Sub sbCopyRangeToAnotherSheet()
Sheets("Sheet1").Range("A1:P100").Copy
Sheets("Sheet3").Activate
ActiveSheet.Paste
Application.CutCopyMode = False
End Sub
Now I want the copied data of sheet1 in sheet3 should be of BLUE color
After copying Shee1's data in sheet3, Sheet2's data will copy below to the Sheet1's data & of which Green color.
After copying both data in Sheet3 Column C will be sorted from smallest to largest.
Try this short routine. You were copying the entire Worksheet.UsedRange property so I will assume that you do not have columns header labels in row 1 that should not be copied.
Sub this_and_that()
'clear Sheet3
With Worksheets("Sheet3")
.Cells(1, 1).CurrentRegion.Clear
End With
With Worksheets("Sheet1")
.Cells(1, 1).CurrentRegion.Copy _
Destination:=Worksheets("Sheet3").Cells(1, 1)
End With
With Worksheets("Sheet2")
.Cells(1, 1).CurrentRegion.Copy _
Destination:=Worksheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
End With
End Sub
You gave no indication of the exact location to start pasting data in Sheet3 (defaulting to an ActiveCell property upon activating a worksheet is not precise) so I have elected to simple clear Sheet3 before the Copy & PAste.
Sub Test1()
Dim Sh1 As Worksheet, Sh3 As Worksheet, Sh2 As Worksheet
' This provides IntelliSense
Set Sh1 = Sheets("Sheet1")
Set Sh2 = Sheets("Sheet2")
Set Sh3 = Sheets("Sheet3")
Sh3.UsedRange.Clear
Sh1.Range("A1:P100").Copy Sh3.Cells(1, 1)
Sh3.Range("A1:P100").Font.Color = vbBlue
Sh2.Range("A1:P100").Copy Sh3.Cells(101, 1)
Sh3.Range("A101:P201").Font.Color = vbGreen
Sh3.UsedRange.Sort Key1:=Sh3.Cells(1, 3), Order1:=xlAscending, Header:=xlGuess
End Sub
The above code works. Problem solved
VBA beginner here, I've got a little problem with program I'm working on.
I need to copy data from last cell in column B from first worksheet and paste it into column A in another worksheet xws, and repeate this operation for five other worksheets with data.
Here's the code, it doesn't work the way it should:
Sub exercise()
Dim ws As Worksheet
Dim rng As Range
'Finding last row in column B
Set rng = Range("B" & Rows.Count).End(xlUp)
For Each ws In ActiveWorkbook.Worksheets
'Don't copy data from xws worksheet
If ws.Name <> "xws" Then
'Storing first copied data in A1
If IsEmpty(Sheets("xws").[A1]) Then
rng.Copy Sheets("xws").Range("A" & Rows.Count).End(xlUp)
'Storing next copied data below previously filled cell
Else
rng.Copy Sheets("xws").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
End If
End If
Next ws
End Sub
There is a problem with ws. referring, but whenever I put it before rng in if statements or before range (set rng = ...) I get errors.
Thanks in advance for any pointers.
You should be declaring rng for each ws inside the loop, like:
Sub exercise()
Dim ws As Worksheet
Dim rng As Range
For Each ws In ActiveWorkbook.Worksheets
'Finding last row in column B
Set rng = ws.Range("B" & ws.Rows.Count).End(xlUp) '<~~ Moved inside the loop
'Don't copy data from xws worksheet
If ws.Name <> "xws" Then
'Storing first copied data in A1
If IsEmpty(Sheets("xws").[A1]) Then
rng.Copy Sheets("xws").Range("A" & Rows.Count).End(xlUp)
'Storing next copied data below previously filled cell
Else
rng.Copy Sheets("xws").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
End If
End If
Next ws
End Sub
As your code is now, rng will be pointing to the ActiveSheet at the time you run the macro, and your code will then copy the same cell on each iteration of the code.