Here is my code.
Sub AddNewMonthToJPR()
Dim sourceSheet As Worksheet
Set sourceSheet = ActiveSheet
For Each ws In ActiveWorkbook.Worksheets
ws.Activate
If ws.Name <> "XSummary" And ws.Name <> "Summary" And ws.Name <> "Legend" And ws.Name <> "DATA" And ws.Name <> "XMastersheet" And ws.Name <> "MasterSheet" Then
Range("C2").EntireColumn.Insert
Range("C2").EntireColumn.Insert
Range("C2").EntireColumn.Insert
Range("C2").EntireColumn.Insert
Range("C2").EntireColumn.Insert
Columns("C:G").Select
Selection.Clear
Range("C1").Select
Sheets("MasterSheet").Select
Columns("C:G").Select
Range("C2").Activate
Selection.Copy
Range("CT1").Select
Range("CT1").Select
Call sourceSheet.Activate
Range("C1").Select
ActiveSheet.Paste 'NEED TO UPDATE SO IT REFERENCES APPROPRIATE SHEET EACH TIME
Range("E4").Select
End If
Next ws
End Sub
ActiveSheet.Paste brings the process back to the start sheet, but instead, it needs to switch to the next sheet in the sequence.
The paste of data is happening in the same worksheet repeatedly instead of moving to the next sheet.
Related
I have an excel file with 100 sheets, all with the same layout, and I need to apply some formatting to all of these sheets.
What I need is a Macro that Loops through all Sheets of a workbook the same code.
I tried this one but is does NOT work
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
Range("A1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "Balance Sheet"
Range("Q1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "Cash Flow"
Next ws
End Sub
Can you help me with this ? Thanks!!
Replace that with:
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
ws.Range("A1").Value = "Balance Sheet"
ws.Range("Q1").Value = "Cash Flow"
Application.CutCopyMode = False
Next ws
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.
I have a really weak experience working with VBA, but now faced an issue where it is really required.
I need to copy cell's value from multiple worksheets (besides "Summary") into one worksheet, but facing a problem. When running a macro, I get around 30 lines with the values I need, but all 30 values belong to the same worksheet. Seems like the loop is running only around 1 worksheet. Could you help me finding the mistake in the code?
Sub CopyTotalSalesPrice()
For Each Worksheet In ActiveWorkbook.Worksheets
If Worksheet.Name <> "Summary" Then
Worksheet.Cells(Rows.Count, 7).End(xlUp).Select
End If
If Selection.Value > "0" Then
Selection.Copy
Worksheets("Summary").Cells(Rows.Count, 6).End(xlUp).Offset(2, 0).PasteSpecial (xlPasteValues)
Range("D4").Select
Selection.Copy
Worksheets("Summary").Cells(Rows.Count, 4).End(xlUp).Offset(2, 0).PasteSpecial (xlPasteValues)
End If
Next Worksheet
Worksheets("Summary").Select
End Sub
when using Cells(Rows.Count, 7).End(xlUp).Select and everything else, they refer to the current sheet. So you either put in front of them Worksheet.Cells(Rows.Count, 7).End(xlUp).Select or you activate the sheet first with Worksheet.Activate
or you can just do as follow:
Sub CopyTotalSalesPrice()
For Each Worksheet In ActiveWorkbook.Worksheets
With Worksheet
If .Name <> "Summary" Then
.Cells(Rows.Count, 7).End(xlUp).Copy Destination:=Worksheets("Summary").Cells(Rows.Count, 6).End(xlUp).Offset(2, 0)
.Range("D4").Copy Destination:=Worksheets("Summary").Cells(Rows.Count, 4).End(xlUp).Offset(2, 0)
End If
End With
Next Worksheet
Worksheets("Summary").Select
End Sub
Try this:
Sub CopyTotalSalesPrice()
For Each Worksheet In ActiveWorkbook.Worksheets
If Worksheet.Name <> "Summary" Then
Worksheet.Select
Worksheet.Cells(Worksheet.Rows.Count, 7).End(xlUp).Select
End If
If Selection.Value > "0" Then
Selection.Copy
Worksheets("Summary").Cells(Worksheet.Rows.Count, 6).End(xlUp).Offset(2, 0).PasteSpecial (xlPasteValues)
Range("D4").Select
Selection.Copy
Worksheets("Summary").Cells(Worksheet.Rows.Count, 4).End(xlUp).Offset(2, 0).PasteSpecial (xlPasteValues)
End If
Next Worksheet
Worksheets("Summary").Select
End Sub
I replaced this Cells(Rows.Count, 7).End(xlUp).Select with Worksheet.Cells(Worksheet.Rows.Count, 7).End(xlUp).Select
I have multiple Excel files in a same folder which contains data in worksheet "Case Tracker". I wanted to copy and paste data to all Excel files from one Excel file "Macro.xlsx". The code is like it copies data from Rahul.xlsx to Macro.xlsx and then from Rohit.xlsx to Macro.xlsx and so on. The problem is that while pasting data from Rohit.xlsx it is overlapping. The code is not finding the next available blank row to paste data and this is due to code Sheets("Sheet1").Range("A1").Select. Can someone help me edit the code
Sub OpenCopyPaste()
' open the source workbook and select the source sheet
Workbooks.Open Filename:="C:\Users\Rahul\Desktop\Test\Rahul.xlsx"
Sheets("Case Tracker").Select
' copy the source range
Sheets("Case Tracker").Range("A:G").Select
Selection.Copy
' select current workbook and paste the values starting at A1
Windows("Macro.xlsx").Activate
Sheets("Sheet1").Select
Sheets("Sheet1").Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode =False
ActiveWorkbook.Save
Workbooks.Open Filename:="C:\Users\Rahul\Desktop\Test\Rohit.xlsx"
Sheets("Case Tracker").Select
' copy the source range
Sheets("Case Tracker").Range("A:G").Select
Selection.Copy
' select current workbook and paste the values starting at A1
Windows("Macro.xlsx").Activate
Sheets("Sheet1").Select
Sheets("Sheet1").Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode =False
ActiveWorkbook.Save
EndSub
Replace
Sheets("Sheet1").Range("A1").Select
With
Dim oCell As Range 'Only insert this line once!
With Sheets("Case Tracker")
Set oCell = .Cells(.Rows.Count, 1).End(xlUp)
End With
If oCell.Row > 1 Then
Set oCell = oCell.Offset(1, 0)
End If
oCell.Select
You should only declare oCell once, so only put this line once at the top:
Dim oCell As Range
Complete:
Sub OpenCopyPaste()
Dim oCell As Range
Dim rowCount As Integer
' open the source workbook and select the source sheet
Workbooks.Open Filename:="C:\Users\Rahul\Desktop\Test\Rahul.xlsx"
Sheets("Case Tracker").Select
' copy the source range
With Sheets("Case Tracker")
rowCount = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range(.Cells(1, 1), .Cells(rowCount, 7)).Select
End With
Selection.Copy
' select current workbook and paste the values starting at A1
Windows("Macro.xlsx").Activate
Sheets("Sheet1").Select
'------------------------------------------------
With Sheets("Sheet1")
Set oCell = .Cells(.Rows.Count, 1).End(xlUp)
End With
oCell.Select
'------------------------------------------------
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveWorkbook.Save
Workbooks.Open Filename:="C:\Users\Rahul\Desktop\Test\Rohit.xlsx"
Sheets("Case Tracker").Select
' copy the source range
With Sheets("Case Tracker")
rowCount = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range(.Cells(1, 1), .Cells(rowCount, 7)).Select
End With
Selection.Copy
' select current workbook and paste the values starting at A1
Windows("Macro.xlsx").Activate
Sheets("Sheet1").Select
'------------------------------------------------
With Sheets("Sheet1")
Set oCell = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
End With
oCell.Select
'------------------------------------------------
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveWorkbook.Save
End Sub
I am trying to get data from every other sheet in the workbook and paste it into a master sheet (Sheet1), but when I run my code nothing happens, Can someone tell me why this is?
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
wb.Sheets("Sheet1").Cells(1, 1).Text = "Started"
i = 1
'cells is row,col
For Each objWorksheet In wb.Worksheets
'ws.Cells(1, i).Value = objWorksheet.Name
'objWorksheet.Activate
'ws = wb.ActiveSheet
doJStuff i, objWorksheet
i = i + 1
Next
wb.Sheets("Sheet1").Cells(1, 1).Text = "DONE"
End Sub
Sub doJStuff(row, ws)
ws.Select
Range("A2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
ActiveSheet.Cells(row, 1).Select
ActiveSheet.Paste
'end paste name
'copy post history and transpose into row 2 on sheet1
ws.Select
Range("H2:H30").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
ActiveSheet.Cells(row, 2).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
'end post history
End Sub
You've got a number of problems with your code. First of all, avoid using Select wherever possible. Second, you are not properly assigning variables. You should put Option Explicit on the top of the module and then make sure you've assigned things correctly.
As for the actualy code, when you are copying/pasting the H2:H30 range into your first sheet you are going to only end up getting the first value in the range for every sheet except the last because you are pasting 28 rows but only incrementing the destination row by one. I didn't fix that but it's worth pointing out. I also left in your comments though they don't make much sense. Without knowing what you are trying to do, I've only cleaned up some of your code but it probably still won't work exactly right.
Sub YourSub()
Dim wb As Workbook
Dim wksht As Worksheet
Dim i As Integer
Set wb = ActiveWorkbook
wb.Sheets("Sheet1").Cells(1, 1).Text = "Started"
i = 1
'cells is row,col
For Each wksht In Worksheets
'ws.Cells(1, i).Value = objWorksheet.Name
'objWorksheet.Activate
'ws = wb.ActiveSheet
doJStuff i, wksht
i = i + 1
Next
wb.Sheets("Sheet1").Cells(1, 1).Text = "DONE"
End Sub
Sub doJStuff(row As Integer, ws As Worksheet)
ws.Range("A2").Copy
Sheets("Sheet1").Cells(row, 1).PasteSpecial
'end paste name
'copy post history and transpose into row 2 on sheet1
ws.Range("H2:H30").Copy
Sheets("Sheet1").Cells(row, 2).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
'end post history
End Sub