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
Related
The code works. It loops through my worksheets in my workbook and excludes the ones listed in the IF statement below.
I am trying to not hard code each sheet name I want to exclude.
I want to create a separate sheet where I enter the sheet names to exclude in the range A1:10 so the IF statement can nab the sheet names.
Dim Ws As Worksheet
For Each Ws In Worksheets
If Ws.Name <> "MainMenu" And Ws.Name <> "All in One View" And Ws.Name <> "Complete" _
And Ws.Name <> "LDD on Hold" And Ws.Name <> "LDD Projects in Queue" And Ws.Name <> "ON HOLD" _
And Ws.Name <> "Blank" And Ws.Name <> "Project Assignments" Then
Set rngData = Ws.UsedRange
rngData.Offset(5, 1).Resize(rngData.Rows.Count - 5, rngData.Columns.Count - 3).Copy Sheet26.Range(ActiveCell.Address)
Range("C6").End(xlDown).Select
ActiveCell.Offset(1, 0).Select
End If
Next Ws
Something like this should work for you. Make sure the name of your destination worksheet, and the name of your exclusion worksheet (I named it ExcludeSheets) are included in the list.
Sub tgr()
Dim wb As Workbook: Set wb = ActiveWorkbook
Dim wsDest As Worksheet: Set wsDest = wb.Worksheets(26)
Dim wsExcl As Worksheet: Set wsExcl = wb.Worksheets("ExcludeSheets")
Dim rExclude As Range: Set rExclude = wsExcl.Range("A1", wsExcl.Cells(wsExcl.Rows.Count, "A").End(xlUp))
Dim aExclude() As Variant
If rExclude.Cells.Count = 1 Then
ReDim aExclude(1 To 1, 1 To 1)
aExclude(1, 1) = rExclude.Value
Else
aExclude = rExclude.Value
End If
Dim ws As Worksheet, rCopy As Range, rDest As Range
For Each ws In wb.Worksheets
Select Case IsError(Application.Match(ws.Name, aExclude, 0))
Case False 'do nothing, worksheet found to be in exclude list
Case Else
Set rCopy = ws.UsedRange.Offset(5, 1).Resize(ws.UsedRange.Rows.Count - 5, ws.UsedRange.Columns.Count - 3)
Set rDest = wsDest.Cells(wsDest.Rows.Count, "C").End(xlUp).Offset(1)
rCopy.Copy rDest
End Select
Next ws
End Sub
Using Match() against a list of excluded sheets:
Dim Ws As Worksheet, rngExcl As Range
Set rngExcl = ThisWorkbook.Worksheets("list").Range("A1:A10")
For Each Ws In Worksheets
If IsError(Application.Match(Ws.Name, rngExcl, 0) Then
Set rngData = Ws.UsedRange
With rngData
.Offset(5, 1).Resize(.Rows.Count - 5, .Columns.Count - 3).Copy _
Sheet26.Range("C6").End(xlDown).Offset(1, 0)
End With
End If
Next Ws
I have a workbook contain about 50 worksheets (sheet 1, sheet 2, sheet 3,........, sheet 50). I want to get the sheet name as a column infront of my data in each sheet. I used following code for that.
Sub tgr1()
Dim ws As Worksheet
Dim wsDest As Worksheet
Set wsDest = Sheets("Sheet1")
For Each ws In ActiveWorkbook.Sheets
If ws.Name <> wsDest.Name Then
ws.Range("A:A").Insert Shift:=xlToRight
'Selection.Insert Shift:=xlToRight
ws.Range("A12").FormulaR1C1 = _
"=IF(RC[1]>0,MID(CELL(""filename"",R[-11]C[1]),FIND(""]"",CELL(""filename"",R[-11]C[1]))+1,255),"""")"
ws.Range("A12").Copy
ws.Range("A13:A500").PasteSpecial xlPasteFormulas
ws.Range("A12:A500").Copy
ws.Range("A12:A500").PasteSpecial xlPasteValues
End If
ActiveWorkbook.Save
Next ws
But this code isn't working for all the sheets i have. it applies to random sheets. What should i do to make it apply for all the sheets.
1. Change ActiveWorkbook to ThisWorkbook
2. To get the worksheet name all you need is ws.Range("A12").Value = Ws.Name
3. No point saving the workbook each time the loop runs. Do it outside the loop.
Is this what you are trying?
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim wsDest As Worksheet
Set wsDest = Sheets("Sheet1")
For Each ws In ThisWorkbook.Sheets
If ws.Name <> wsDest.Name Then
ws.Columns(1).Insert Shift:=xlToRight
ws.Range("A12:A500").Value = ws.Name
End If
Next ws
ThisWorkbook.Save
DoEvents
End Sub
I have sheets 1 2 3 4 and all contains the same set of columns(There are other tabs as well in the book with different set of columns).
I need to copy all tab data in to one sheet which is already there in the workbook named "Draft".
I have found this code and tried:
Sub CopyFromWorksheets()
Dim wrk As Workbook
'Workbook object - Always good to work with object variables
Dim sht As Worksheet
'Object for handling worksheets in loop
Dim trg As Worksheet
'Master Worksheet
Dim rng As Range
'Range object
Dim colCount As Integer
'Column count in tables in the worksheets
Set wrk = ActiveWorkbook
'Working in active workbook
For Each sht In wrk.Worksheets
If sht.Name = "Master" Then
MsgBox "There is a worksheet called as 'Master'." & vbCrLf & _
"Please remove or rename this worksheet since 'Master' would be" & _
"the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error"
Exit Sub
End If
Next sht
'We don't want screen updating
Application.ScreenUpdating = False
'Add new worksheet as the last worksheet
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
'Rename the new worksheet
trg.Name = "Master"
'Get column headers from the first worksheet
'Column count first
Set sht = wrk.Worksheets(1)
colCount = sht.Cells(1, 255).End(xlToLeft).Column
'Now retrieve headers, no copy&paste needed
With trg.Cells(1, 1).Resize(1, colCount)
.Value = sht.Cells(1, 1).Resize(1, colCount).Value
'Set font as bold
.Font.Bold = True
End With
'We can start loop
For Each sht In wrk.Worksheets
'If worksheet in loop is the last one, stop execution (it is Master worksheet)
If sht.Index = wrk.Worksheets.Count Then
Exit For
End If
'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
'Put data into the Master worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
Next sht
'Fit the columns in Master worksheet
trg.Columns.AutoFit
'Screen updating should be activated
Application.ScreenUpdating = True
End Sub
which is working fine but creating new tab and copied data from all tabs irrespective of required tab.
which is working fine but creating new tab and copied data from all tabs irrespective of required tab.
Without any testing, and if i understand correctly what you are trying to achieve (copy your Sheet 1,2,3,4 to Draft sheet), please see below the modified code (from your working code):
Sub CopyFromWorksheets()
Dim wrk As Workbook
'Workbook object - Always good to work with object variables
Dim sht As Worksheet
'Object for handling worksheets in loop
Dim trg As Worksheet
'Master Worksheet
Dim rng As Range
'Range object
Dim colCount As Integer
'Column count in tables in the worksheets
Set wrk = ActiveWorkbook
'Working in active workbook
'We don't want screen updating
Application.ScreenUpdating = False
'Add new worksheet as the last worksheet
Set trg = wrk.Worksheets("Draft")
'Get column headers from the first worksheet
'Column count first
Set sht = wrk.Worksheets(1)
colCount = sht.Cells(1, 255).End(xlToLeft).Column
'Now retrieve headers, no copy&paste needed
With trg.Cells(1, 1).Resize(1, colCount)
.Value = sht.Cells(1, 1).Resize(1, colCount).Value
'Set font as bold
.Font.Bold = True
End With
'We can start loop
For Each sht In wrk.Worksheets
'If worksheet in loop is the last one, stop execution (it is Master worksheet)
If sht.Name = "Sheet1" or sht.Name = "Sheet2" or sht.Name = "Sheet3" or sht.Name = "Sheet4" Then
'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
'Put data into the Master worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
End If
Next sht
'Fit the columns in Master worksheet
trg.Columns.AutoFit
'Screen updating should be activated
Application.ScreenUpdating = True
End Sub
I am new to macro and I am struggling with creating macro that will allow me to copy and paste the same range of cells from all sheets in worksheet and paste them in the first sheet in the next available cell. I know that is has to be done with the combination of loop and lastrow. Unfortunately, all my attempts fail
This is the macro that I would like to run through all sheet, but the sheets name is different
Sub Macro10()
'
' Macro10 Macro
'
'
Sheets("1449GW.WLWaterLevel.0sec").Select
Range("H1:Y2").Select
Selection.Copy
Sheets("Sheet1").Select
Range("A1").Select
ActiveSheet.Paste
End Sub
Try this. Two versions as not sure what you're asking.
If you are copying the same range from a single sheet to multiple sheets
Sub Macro10()
Dim ws As Worksheet, ws1 As Worksheet
Set ws1 = Worksheets("1449GW.WLWaterLevel.0sec")
For Each ws In Worksheets
If ws.Name <> ws1.Name Then
ws1.Range("H1:Y2").Copy ws.Range("A" & Rows.Count).End(xlUp)(2)
End If
Next ws
End Sub
If you are copying the same range from multiple sheets to a single sheet
Sub Macro10()
Dim ws As Worksheet, ws1 As Worksheet
Set ws1 = Worksheets("Sheet1")
For Each ws In Worksheets
If ws.Name <> ws1.Name Then
ws.Range("H1:Y2").Copy ws1.Range("A" & Rows.Count).End(xlUp)(2)
End If
Next ws
End Sub
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