I have a masterworkbook, which includes variable amount of Worksheets, which have Name as table1 and then the rest of the Sheets are called data, data(1), data(2) etc. I want to copy all the column&rows of the Sheets which has Name starting with "data" and paste this to worksheet called "Table1".
Can someone help me with this?
Based on the information, you could try something like this:
Sub getDataFromSheets()
'loop throug all sheets in workbook
For Each sh In ThisWorkbook.Worksheets
'check sheet name
If Left(sh.Name, 4) = "data" Then
With sh
'get last row on data sheet
'***** CHANGE THE COLUMN LETTER IF REQUIRED
lRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'get last row on table sheet
lRowTB = Sheets("Table1").Cells(Sheets("Table1").Rows.Count, "A").End(xlUp).Row + 1
'copy the data from data to table sheet
'***** ADJUST THE COLUMN LETTERS TO YOUR NEED *******
.Range("A1:E" & lRow).Copy Destination:=Sheets("Table1").Range("A" & lRowTB)
End With
End If
Next sh
End Sub
I made some additions to the codes and added the ability to take the subtotal of the desired column:
Application.DisplayAlerts = False
ActiveWorkbook.Worksheets("Grand_Table").Delete
Application.DisplayAlerts = True
Sheets(1).Select
Worksheets.Add
Sheets(1).Name = "Grand_Table"
Sheets(2).Activate
Range("A1").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A1")
For J = 2 To Sheets.Count
Sheets(J).Activate
Range("A1").Select
Selection.CurrentRegion.Select
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
Last = FindLastRow(Sheets(1))
Selection.Copy
With Sheets(1).Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
Next
'Application.CutCopyMode = False
Sheets("Grand_Table").Activate
Sheets("Grand_Table").UsedRange.Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Selection.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(6), _
Replace:=True, PageBreaks:=True, SummaryBelowData:=True
Related
This is a screenshot of my excel doc.
I want to apply filters based on values: Bimbo Mexico, Bimbo Canada and copy and paste the values(from column A & B) in a new sheet. I want to do this using macro as I am building a template for a client. Is there a way to do this? I know it can be done manually using filters manually but I want it to be based on a macro
I want the output like this:
I used recording macro and this is the macro I got,
Sub RecordedMacro()
'
' RecordedMacro Macro
'
' Keyboard Shortcut: Ctrl+l
'
Sheets("report").Select
Range("C1").Select
ActiveSheet.Range("$A$1:$S$1001").AutoFilter Field:=3, Criteria1:="Barcel"
Columns("L:L").Select
Selection.Copy
Sheets("SkuRounds").Select
Columns("S:S").Select
ActiveSheet.Paste
Sheets("report").Select
ActiveSheet.Range("$A$1:$S$1001").AutoFilter Field:=3, Criteria1:= _
"Bimbo Canada"
Columns("L:L").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("SkuRounds").Select
Columns("T:T").Select
ActiveSheet.Paste
Sheets("report").Select
ActiveSheet.Range("$A$1:$S$1001").AutoFilter Field:=3, Criteria1:= _
"Bimbo Latin Centro"
Columns("L:L").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("SkuRounds").Select
Columns("U:U").Select
ActiveSheet.Paste
Sheets("report").Select
ActiveSheet.Range("$A$1:$S$1001").AutoFilter Field:=3, Criteria1:= _
"Bimbo México"
Columns("L:L").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("SkuRounds").Select
Columns("V:V").Select
ActiveSheet.Paste
End Sub
I am copying data from sheet(report) to sheet(skurounds)
Give this a try:
Sub tgr()
Dim wb As Workbook
Dim wsReport As Worksheet
Dim wsSKU As Worksheet
Dim dictUnqCompanies As Object
Dim aCompanies As Variant
Dim vCompany As Variant
Dim lDestCol As Long
Set wb = ActiveWorkbook
Set wsReport = wb.Sheets("report")
Set wsSKU = wb.Sheets("skurounds")
Set dictUnqCompanies = CreateObject("Scripting.Dictionary")
lDestCol = wsSKU.Columns("S").Column
'Clear previous results
wsSKU.Range(wsSKU.Cells(1, "S"), wsSKU.Cells(1, wsSKU.Columns.Count)).EntireColumn.Clear
With wsReport.Range("C2", wsReport.Cells(wsReport.Rows.Count, "C").End(xlUp))
If .Row < 2 Then Exit Sub 'No data
If .Rows.Count = 1 Then
'Only 1 row of data
wsSKU.Cells(1, lDestCol).Value = .Value
.Parent.Cells(.Row, "L").Copy wsSKU.Cells(2, lDestCol)
Exit Sub
Else
aCompanies = .Value
End If
End With
For Each vCompany In aCompanies
If Not dictUnqCompanies.exists(vCompany) Then
dictUnqCompanies.Add vCompany, vCompany
With wsReport.Range("C1", wsReport.Cells(wsReport.Rows.Count, "C").End(xlUp))
.AutoFilter 1, vCompany
wsSKU.Cells(1, lDestCol).Value = vCompany
Intersect(.Parent.Columns("L"), .Offset(1).EntireRow).Copy wsSKU.Cells(2, lDestCol)
lDestCol = lDestCol + 1
.AutoFilter
End With
End If
Next vCompany
End Sub
I have two sheets:
SheetA has a list of employee Nr.
Sheet B has a form that needs to be filled out AND printed with each employee numbers on it (then vlookup formulas fill out the rest)
Now I can copy paste each employee ID manually, but there are 330+ employees, that is a bit too much.
I would like to copy cell A2 in Sheet_A, paste it into cell A2 Sheet_B AND print the form, then go to cell A3 in Sheet_A copy it, paste it into A2 in Sheet_B and so on... I would like to repeat this process 337 times.
I created this macro, but I don't know how to make it always choose the next cell in Sheet_A AND repeat itself 337 times. (or depending on how many employees we have at a certain time)
Sub Copy_Cell()
' Copy_Cell Macro
Sheets("Sheet A").Select
Range("A2").Select
Selection.Copy
Sheets("Sheet B").Select
Range("A2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
IgnorePrintAreas:=False
End Sub
You just need to loop through each of your rows:
Sub Copy_Cell()
Dim r As Long
'Use a "With" block to save having to constantly type "Worksheets("Sheet A")"
'inside the block
With Worksheets("Sheet A")
'Loop through all values in column A, thus saving the trouble of
'hard-coding the last row number to be used
For r = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
'Just copy the value directly from one worksheet to another, thus
'avoiding copy/paste
Worksheets("Sheet B").Range("A2").Value = .Cells(r, "A").Value
Worksheets("Sheet B").PrintOut Copies:=1, _
Collate:=True, _
IgnorePrintAreas:=False
Next r
End With
End Sub
Sub Copy_Cell() ' Copy_Cell Macro
Dim i as Integer
For i = 1 To 337
Sheets("Sheet A").Activate
ActiveSheet.Cells(i + 1, 1).Select
Selection.Copy
Sheets("Sheet B").Activate
Range("A2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
IgnorePrintAreas:=False
Next i
End Sub Image Image
Sub Copy_Cell()
Dim row as Integer
Do While row <= 337
Sheets("Sheet A").Activate
Sheets("Sheet A").Cells(row + 1, 1).Copy
Sheets("Sheet B").Activate
Range("A2").Select
ActiveSheet.Paste
ActiveWindow.SelectedSheets.PrintOut Copies:=1
row = row + 1
Loop
End sub
I am new to VBA and have primarily used it in conjunction with creating a macro. As you can see from the code below, I am trying to take tables from three different tabs and merge them into one. However, I am having a hard time understanding how to ensure that each table will paste directly underneath the previous table and not overwrite it (especially when each month new rows are created).
Thank you in advance for any help you can provide.
' Step_4_Combination_Tab Macro
Sheets("Past Data").Select
Range("A2:M2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Combination").Select
Range("A1").Select
ActiveSheet.Paste
Range("A1").Select
Selection.End(xlDown).Select
Range("A5483").Select
Sheets("Actual").Select
Range("A5:M5").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Combination").Select
Range("A5483").Select
ActiveSheet.Paste
Range("A5483").Select
Selection.End(xlDown).Select
Range("A8341").Select
Sheets("Forecast").Select
Range("A4:M4").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Combination").Select
ActiveSheet.Paste
Selection.End(xlUp).Select
End Sub
The following code might do what you want:
Sub mergeSheets()
Set targetSheet = Sheets("Combination")
For i = 1 To Sheets.Count
If Sheets(i).Name <> "Combination" Then
Last = LastRow(Sheets("Combination"))
Sheets(i).UsedRange.Copy targetSheet.Cells(Last + 1, 1)
End If
Next i
End Sub
Function LastRow(sh As Worksheet)
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End Function
some codebits taken from here https://www.exceltip.com/cells-ranges-rows-and-columns-in-vba/copy-the-usedrange-of-each-sheet-into-one-sheet-using-vba-in-microsoft-excel.html
You will need to find the last row that has data and paste you next table there.
LR = Sheets("Combination").Range("A" & Rows.Count).End(xlUp).Row
Pasterange = "A" & LR
Sheets("Combination").Range(Pasterange).Paste
I am guessing that you want to copy data from tabs "Past data", "Actual" and "Forecast" to "Consolidated". Am I right? And for some odd reason data in source worksheets begins in different rows. I would do it this way:
Sub AllToCons()
CopyToCons "Past data", 2
CopyToCons "Actual", 5
CopyToCons "Forecast", 4
End Sub
Sub CopyToCons(wsName As String, lRow As Long)
'wsName: name of sheet we are copying from
'lRow: number of row where data start
Dim ws As Worksheet
Dim wsCons As Worksheet
Dim rng As Range
Set wsCons = ThisWorkbook.Worksheets("Consolidated")
Set ws = ThisWorkbook.Worksheets(wsName)
With ws
Set rng = Range(.Range("A" & lRow), .Range("M" & .Cells.Rows.Count).End(xlUp))
End With
rng.Copy
With wsCons
.Range("A" & .Cells.Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteAll
End With
If you want to paste values only, type xlPasteValues instead of xlPasteAll.
Hope it helped.
So I have now changed the macro below to this and am getting a
Runtime 1004 error at
ActiveSheet.Name = ShipperName
Code:
Sub CopyShipperToNewSheet()
Dim LR As Long
Dim ShipperName As String
' Last row of your data
LR = Range("A" & Cells.Rows.Count).End(xlUp).Row
' Loop Name range ( Column U)
For i = 2 To Range("U" & Cells.Rows.Count).End(xlUp).Row
ShipperName = Cells(i, 21)
' Use filter
Cells.Select
Selection.AutoFilter
' field =4 (column D----Shippers Name)
ActiveSheet.Range("$A$1:$S$" & LR).AutoFilter Field:=4, Criteria1:=ShipperName
' Copy visible cell
[A1].CurrentRegion.Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
' Paste to new sheet
Sheets.Add After:=ActiveSheet
Selection.PasteSpecial Paste:=xlPasteValues
ActiveSheet.Name = ShipperName
' Go back sheet1
Sheets("Sheet1").Select
Selection.AutoFilter
Next i
End Sub
First get unique shipper name
The screenshot:
You can change this macro for yourself:
Sub CopyShipperToNewSheet()
Dim LR As Long
Dim ShipperName As String
' Last row of your data
LR = Range("A" & Cells.Rows.Count).End(xlUp).Row
' Loop Name range ( Column F)
For i = 2 To Range("F" & Cells.Rows.Count).End(xlUp).Row
ShipperName = Cells(i, 6)
' Use filter
Cells.Select
Selection.AutoFilter
' field =4 (column D----Name)
ActiveSheet.Range("$A$1:$D$" & LR).AutoFilter Field:=4, Criteria1:=ShipperName
' Copy visible cell
[A1].CurrentRegion.Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
' Paste to new sheet
Sheets.Add After:=ActiveSheet
Selection.PasteSpecial Paste:=xlPasteValues
ActiveSheet.Name = ShipperName
' Go back sheet1
Sheets("Sheet1").Select
Selection.AutoFilter
Next i
End Sub
Hope this will help you.
I need to build a Macro that creates new workbooks based on the values in Column M (distributors). So I would have a new workbook for each distributor. I've tried modifying others on here that were attempting something similar with no success. Thanks in advance.
Here is the macro that I'm trying to get similar results from. The differences are that I need mine based off of column M instead of B. Also, my sheet's name is "taxes_20150619-145507", not Sheet1. I've tried to change these in the code but keep getting errors!
Sub details()
Dim thisWB As String
Dim newWB As String
thisWB = ActiveWorkbook.Name
On Error Resume Next
Sheets("tempsheet").Delete
On Error GoTo 0
Sheets.Add
ActiveSheet.Name = "tempsheet"
Sheets("Sheet1").Select
If ActiveSheet.AutoFilterMode Then
Cells.Select
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
End If
Columns("B:B").Select
Selection.Copy
Sheets("tempsheet").Select
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
If (Cells(1, 1) = "") Then
lastrow = Cells(1, 1).End(xlDown).Row
If lastrow <> Rows.Count Then
Range("A1:A" & lastrow - 1).Select
Selection.Delete Shift:=xlUp
End If
End If
Columns("A:A").Select
Columns("A:A").AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("B1"), Unique:=True
Columns("A:A").Delete
Cells.Select
Selection.Sort _
Key1:=Range("A2"), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
lMaxSupp = Cells(Rows.Count, 1).End(xlUp).Row
For suppno = 2 To lMaxSupp
Windows(thisWB).Activate
supName = Sheets("tempsheet").Range("A" & suppno)
If supName <> "" Then
Workbooks.Add
ActiveWorkbook.SaveAs supName
newWB = ActiveWorkbook.Name
Windows(thisWB).Activate
Sheets("Sheet1").Select
Cells.Select
If ActiveSheet.AutoFilterMode = False Then
Selection.AutoFilter
End If
Selection.AutoFilter Field:=2, Criteria1:="=" & supName, _
Operator:=xlAnd, Criteria2:="<>"
lastrow = Cells(Rows.Count, 2).End(xlUp).Row
Rows("1:" & lastrow).Copy
Windows(newWB).Activate
ActiveSheet.Paste
ActiveWorkbook.Save
ActiveWorkbook.Close
End If
Next
Sheets("tempsheet").Delete
Sheets("Sheet1").Select
If ActiveSheet.AutoFilterMode Then
Cells.Select
ActiveSheet.ShowAllData
End If
End Sub
Try this.
Sub AddNew()
Set NewBook = Workbooks.Add
With NewBook
.SaveAs fileName:="Allsales.xls" 'Replace with the column M's value
End With
End Sub