Can some one help with a vba code to copy a range from multiple worksheets (52 weeks) into a summary sheet in the same workbook. Range is the same in each worksheet. I want the data to be copied and pasted in 52 columns in the ssummary worksheet, from week1 to week 52.
I have found this code online:
Sub SummurizeSheets()
Dim ws As Worksheet
Application.ScreenUpdating = False
Sheets("Summary").Activate
For Each ws In Worksheets
If ws.Name <> "Summary" Then
ws.Range("F46:O47").Copy
Worksheets("Summary").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)
End If
Next ws
End Sub
Try below code .Also set Application.ScreenUpdating = True.
Sub SummurizeSheets()
Dim ws As Worksheet
Dim j As Integer, col As Integer
Application.ScreenUpdating = False
Sheets("Summary").Activate
For Each ws In Worksheets
If ws.Name <> "Summary" Then
ws.Range("k3:k373").Copy
col = Worksheets("Summary").Range("IV1").End(xlToLeft).Column + 1
Worksheets("Summary").Cells(1, col).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End If
Next ws
Columns(1).Delete
Range("A1").Activate
Application.ScreenUpdating = True
End Sub
Related
Code below - it works well for the active sheet but then doesn't do anything further, I've tried a couple of methods online but I don't understand why it won't loop through my other sheets. Any help greatly appreciated,
Sub Worksheet_Loop()
'Loop through each worksheet in a workbook
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
'What we gonna do
Dim WSR As Range
Set WSR = Range("A4:GG100")
Dim Test_Criteria As String
Test_Criteria = Range("a1")
On Error Resume Next
WSR.ShowAllData
On Error GoTo 0
WSR.Range("a4:gg1000").AutoFilter Field:=6, Criteria1:="<>" & Test_Criteria, Operator:=xlFilterValues
'2. Delete Rows
Application.DisplayAlerts = False
WSR.Range("a2:gg1000").SpecialCells(xlCellTypeVisible).EntireRow.Delete
Application.DisplayAlerts = True
If ActiveSheet.AutoFilterMode Then ActiveSheet.ShowAllData
Next ws
End Sub
I am using the macro below by clicking a button each time I want to run it. This works ok but is quite time consuming.
In the Summary sheet (range H2:H21) of the workbook I have a list of ID numbers which I have been manually pasting into E3 before running the macro.
Instead of doing this I would like to amend the macro so it loops through all the IDs when I click the button.
The workbook is quite big and takes a while to calculate each time a new ID is pasted in so this needs to be factored in.
Can anyone show me have to do these things?
Sub CreateNewSheet()
Application.ScreenUpdating = False
Application.Calculation = xlManual
With Workbooks("Batsmen.xlsx").Worksheets.Add()
.Name = ThisWorkbook.Worksheets("Summary").Range("E3").Value
End With
With ThisWorkbook.Worksheets("Summary").Range("A22:J63").Copy
Workbooks("Batsmen.xlsx").Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteValues
Workbooks("Batsmen.xlsx").Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteFormats
Workbooks("Batsmen.xlsx").Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
Workbooks("Batsmen.xlsx").Sheets(1).Range("A:J").Font.Size = 10
End With
With ThisWorkbook.Worksheets("Summary").Range("A22:J27").Copy
With Workbooks("Batsmen.xlsx").Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(2)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
.Font.Size = 10
End With
End With
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
End Sub
This can be optimized, but should get you started.
Check the code's comments and adjust it to fit your needs.
You can put the cursos inside the Process procedure, press F8 key and see what the code does.
EDIT: Added summarySheet.Range("E3").value = cell.value to the loop
Option Explicit
Public Sub Process()
Dim targetWorkbook As Workbook
Dim summarySheet As Worksheet
Dim sourceRange As Range
Dim cell As Range
' Customize this settings
Set targetWorkbook = Workbooks("Batsmen.xlsx")
Set summarySheet = ThisWorkbook.Worksheets("Summary")
Set sourceRange = summarySheet.Range("H2:H21")
Application.ScreenUpdating = False
Application.Calculation = xlManual
' Loop through each cell in source range
For Each cell In sourceRange.Cells
' Validate that cell has a value
If cell.Value <> vbNullString Then
' Fill E3 with cell value from range in column H
summarySheet.Range("E3").value = cell.value
' Execute procedure to create new sheet
CreateNewSheet targetWorkbook, cell.Value, summarySheet
End If
Next cell
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
End Sub
Private Sub CreateNewSheet(ByVal targetWorkbook As Workbook, ByVal newSheetName As String, ByVal summarySheet As Worksheet)
Dim targetSheet As Worksheet
Set targetSheet = targetWorkbook.Worksheets.Add
targetSheet.Name = newSheetName
summarySheet.Range("A22:J63").Copy
With targetSheet
.Range("A1").PasteSpecial Paste:=xlPasteValues
.Range("A1").PasteSpecial Paste:=xlPasteFormats
.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
.Range("A:J").Font.Size = 10
End With
summarySheet.Range("A22:J27").Copy
With targetSheet.Range("A" & Rows.Count).End(xlUp).Offset(2)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
.Font.Size = 10
End With
End Sub
Let me know if it works
The code below should answer your question because it does create the sheets you want.
Sub CreateNewSheet()
Dim Wb As Workbook
Dim WbBat As Workbook
Dim WsSum As Worksheet
Dim NamesRange As Range
Dim i As Integer
Dim TabName As String
With Application
.ScreenUpdating = False
.Calculation = xlManual
End With
Set Wb = ThisWorkbook
Set WbBat = Workbooks("Batsmen.xlsx")
Set WsSum = Wb.Worksheets("Summary")
Set NamesRange = WsSum.Range("H2:H21")
For i = 1 To NamesRange.Cells.Count
TabName = Trim(NamesRange.Cells(i).Value)
If Len(TabName) Then ' skip if name is blank
With WbBat.Worksheets.Add()
.Name = TabName
WsSum.Range("A22:J63").Copy Destination:=.Cells(1, "A")
WsSum.Range("A22:J27").Copy Destination:=.Cells(.Rows.Count, "A").End(xlUp).Offset(2)
.Range("A:J").Columns.AutoFit
.Range("A1:J" & .Cells(.Rows.Count, "A").End(xlUp).Row).Font.Size = 10
End With
End If
Next i
With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
End With
End Sub
Regrettably, it doesn't provide you usable code because it pastes the same data to all sheets. I presume that you have a plan how to vary the data. Unfortunately, I failed to understand such a plan from your question. However, I suspect that you will be able to modify the code to make it useful.
I want to copy all columns from "B" until the end of the sheet into a new sheet named "combined". The Header table in sheets "Combined" is the same of every sheets ("A").
Sub Combine()
' Sheets(1).Select
' Worksheets.Add ' add a sheet in first place
Sheets(1).Name = "Combined"
' copy headings
Sheets(2).Activate
Range("A1").EntireColumn.Select
Selection.Copy Destination:=Sheets(1).Range("A1")
Dim ws As Worksheet
Dim wsDest As Worksheet
Set wsDest = Sheets("Combined")
For Each ws In ActiveWorkbook.Sheets
If ws.Name <> wsDest.Name Then
ws.Range("B1", ws.Range("B1").End(xlToRight).End(xlDown)).Copy
wsDest.Cells(1, Columns.Count).End(xlToLeft).Offset("B").PasteSpecial xlPasteValues
End If
Next ws
End Sub
.Offset("B") isn't a valid syntax
to shift one column to the right you want .Offset(, 1)
Dim ws As Worksheet
Dim wsDest As Worksheet
Set wsDest = Sheets("Combined")
For Each ws In ActiveWorkbook.Sheets
If ws.Name <> wsDest.Name Then
ws.Range("B1", ws.Range("B1").End(xlToRight).End(xlDown)).Copy
wsDest.Cells(1, Columns.Count).End(xlToLeft).Offset(, 1).PasteSpecial xlPasteValues
End If
Next ws
I need to sort multiple worksheets at once using this script
Sub SortAllSheets()
Dim WS As Worksheet
ActiveSheet.Range("a2:f2").Select
Selection.Copy
On Error Resume Next
Application.ScreenUpdating = False
For Each WS In Worksheets
WS.Columns("A:F").Sort Key1:=WS.Columns("D"), Order1:=xlAscending
Next WS
ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteAll
Application.ScreenUpdating = True
End Sub
Is there a way to how to define that the first row(header)in every worksheet will be excluded from the sorting? I tried to modify the data input or add some extra function, but with no success. Thanks for any advices.
an example:
Dim strDataRange As Range
Dim keyRange As Range
Set strDataRange = Range("Your Data Range")
Set keyRange = Range("Your Sort by Column")
strDataRange.Sort Key1:=keyRange, Header:=xlYes
so using your code:
Sub SortAllSheets()
Dim WS As Worksheet
ActiveSheet.Range("a2:f2").Select
Selection.Copy
On Error Resume Next
Application.ScreenUpdating = False
For Each WS In Worksheets
WS.Columns("A:F").Sort Key1:=WS.Columns("D"), Order1:=xlAscending, Header:=xlYes
Next WS
ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteAll
Application.ScreenUpdating = True
End Sub
The code from this forum is what I used as a starting point. I am trying to modify it to copy multiple sheets and paste them all as values, instead of just one sheet.
I copied multiple sheets using worksheets(array(1,2,3)).copy. I think the problem is With ActiveSheet.UsedRange because it is only replacing the first sheet as values and leaving the remaining sheets as formulas.
What do I need to change so that all the sheets paste as values?
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.DisplayAlerts = False
Worksheets(Array("Sheet 1","Sheet 2","Sheet 3").Copy
With ActiveSheet.UsedRange
.Value = .Value
End With
Set wbNew = ActiveWorkbook
wbNew.SaveAs "L:\Performance Data\UK Sales\Sales (Latest).xlsx"
wbNew.Close True
Application.DisplayAlerts = True
End Sub
You need to loop through the sheets:
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.UsedRange.Value = ws.UsedRange.Value
Next ws
So, with your code, you could do it like this:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim wbOld As Workbook, wbNew As Workbook
Dim ws As Worksheet, delWS As Worksheet
Dim i As Long, lastRow As Long, lastCol As Long
Dim shts() As Variant
Dim rng As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wbOld = ActiveWorkbook
shts() = Array("Sheet 1", "Sheet 2", "Sheet 3")
Set wbNew = Workbooks.Add
Set delWS = ActiveSheet
wbOld.Worksheets(Array("Sheet 1", "Sheet 2", "Sheet 3")).Copy wbNew.Worksheets(1)
delWS.Delete
For i = LBound(shts) To UBound(shts)
With wbNew.Worksheets(shts(i))
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set rng = .Range(.Cells(1, 1), .Cells(lastRow, lastCol))
rng.Value = rng.Value
End With
Next i
wbNew.SaveAs "L:\Performance Data\UK Sales\Sales (Latest).xlsx"
wbNew.Close True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Note: I am not sure which workbook you want to paste the values in. As it is above, it does this in the COPIED workbook, not original.