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.
Related
Here is my current code. It loops fine and enters the data I need but it does not stop when I would like it to. I need it to stop when it the cell in column B is found to be blank.
Sub Insert_Tasks_Info()
'
' Insert_Tasks_Info Macro
'
Dim counter As Integer
counter = 4
'runs macor until first empty cell in Column "B"
Do Until ThisWorkbook.Sheets("Data").Cells(counter, 2).Value = ""
'copies order task info and pastes into data tab
Sheets("Template").Select
Range("A4:G9").Select
Selection.Copy
Sheets("Data").Select
Range("A3").Select
Selection.End(xlDown).Select
NextFree = Range("A3:A" & Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row
Range("A" & NextFree).Select
Selection.Insert Shift:=xlDown
'copies hours info and pastes into data tab
Sheets("Template").Select
Range("F3:AA9").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Data").Select
Range("F2").Select
Selection.End(xlDown).Select
NextFree = Range("F2:F" & Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row
Range("F" & NextFree).Select
ActiveSheet.Paste
Call Insert_Zone
counter = counter + 1
Loop
End Sub
I recorded a macro & integrated together with some codes I researched and tested, which worked individually. However, having combined them all together, I stumbled across errors running the macro. Pop out a message box which displays
Compile Error: Expected End With
Would appreciate all the help I could get to solve it
Sub Book1UpdateDelete()
'
' Book1UpdateDelete Macro
'
' Keyboard Shortcut: Ctrl+g
'
'Select values in a column from specified workbook and sheet
Dim LR As Long, cell As Range, rng As Range
Windows("Y738 Data").Activate
With Sheets("Graph data")
LR = .Range("B" & Rows.Count).End(xlUp).Row
For Each cell In .Range("B4:B" & LR)
If cell.Value <> "" Then
If rng Is Nothing Then
Set rng = cell
Else
Set rng = Union(rng, cell)
End If
End If
Next cell
rng.Select
End With
Selection.Copy
'Open next workbook
Windows("Y783").Activate
'Open Sheet L
Sheets("L").Select
'Select empty field fromn column AA
Range("AA" & Rows.Count).End(xlUp).Offset(1).Select
'paste selection to empty field
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Go back to previous workbook & delete column
Windows("Y738").Activate
With Sheets("Graph data")
Columns("B:B").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Sheets("Graph Data").Select
End Sub
You've missed and end with at the bottom of your code.
Try this (untested)
Sub Book1UpdateDelete()
'
' Book1UpdateDelete Macro
'
' Keyboard Shortcut: Ctrl+g
'
'Select values in a column from specified workbook and sheet
Dim LR As Long, cell As Range, rng As Range
Windows("Y738 Data").Activate
With Sheets("Graph data")
LR = .Range("B" & Rows.Count).End(xlUp).Row
For Each cell In .Range("B4:B" & LR)
If cell.Value <> "" Then
If rng Is Nothing Then
Set rng = cell
Else
Set rng = Union(rng, cell)
End If
End If
Next cell
rng.Select
End With
Selection.Copy
'Open next workbook
Windows("Y783").Activate
'Open Sheet L
Sheets("L").Select
'Select empty field fromn column AA
Range("AA" & Rows.Count).End(xlUp).Offset(1).Select
'paste selection to empty field
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Go back to previous workbook & delete column
Windows("Y738").Activate
With Sheets("Graph data")
Columns("B:B").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Sheets("Graph Data").Select
End with
End Sub
I am trying to insert the correct country map JPG in the correct country XLSX. By "correct" I mean there is one map for each XLSX - Albania.jpg into Albania.xlxs, Andorra.jpg into Andorra.xlxs, etc.
My macro is to do the following:
Enter country name and year in User Form worksheet cells B2 and B3 (works fine!).
Enter country population and income level in Countries worksheet cells B1 and E1 (works fine!).
Insert country map JPG in User Form worksheet at cell A18 (cannot get this to loop!).
Save the workbook as CountryName.xlxs (works fine!).
I have tried using Filename = Dir(Path & "*.jpg") and ActiveSheet.Pictures.Insert without success. I think I need to use ActiveSheet.Pictures.Insert because the cells above the map's position (cell A18) will expand and the map needs to move down.
Sub SaveCountryYear_XLSX_English_map()
Dim lRow, x As Integer
Dim wbName As String
Dim MapPath As String 'Not used in example below
Dim MapName As String 'Not used in example below
Dim index As Integer
Application.DisplayAlerts = False
Application.ScreenUpdating = False
lRow = Range("A" & Rows.Count).End(xlUp).Row
x = 1
Do
x = x + 1
Worksheets("Countries").Activate
'1. Enter country name and year in User Form worksheet cells B2 and B3.
Range("A" & x).Select
Selection.Copy
Sheets("User Form").Select
Range("B2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets("Countries").Select
Range("B" & x).Select
Selection.Copy
Sheets("User Form").Select
Range("B3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'2. Enter country population and income level in Countries worksheet cells B1 and E1.
Sheets("Countries").Select
Range("C" & x).Select
Selection.Copy
Sheets("Table").Select
Range("B1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets("Countries").Select
Range("D" & x).Select
Selection.Copy
Sheets("Table").Select
Range("E1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'3. Insert country map JPG in User Form worksheet at cell A18
'(cannot get this to loop!).
'The following is just an example - it works,
'but without loop of course (inserts the named file correctly).
Sheets("User Form").Select
Range("A18").Select
ActiveSheet.Pictures.Insert( _
"C:\temp\profiles\2017\Maps\EN JPGs\Albania_EN.jpg").Select
Sheets("Countries").Select
'4. Save the workbook as CountryName.xlxs.
wbName = Range("A" & x).Value & "_" & Range("B" & x).Value & "_EN"
ActiveWorkbook.SaveAs Filename:="C:\temp\profiles\2017\Production\Batch_EN_1\" _
& wbName & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Loop Until x = lRow
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
edited after OP's clarifications
you may want to try this refactored code:
Option Explicit
Sub SaveCountryYear_XLSX_English_map()
Dim wbName As String
Dim MapPath As String 'Not used in example below
Dim MapName As String 'Not used in example below
Dim index As Integer 'Not used in example below
Dim cell As Range
Application.DisplayAlerts = False
Application.ScreenUpdating = False
With Worksheets("Countries") '<--| reference "Countries" worksheet of your currently active workbook
For Each cell In .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).SpecialCells(XlCellType.xlCellTypeConstants, xlTextValues) '<--| loop through referenced worksheet column A cells filled with some text from A2 down to last not empty one
'1. Enter country name and year in User Form worksheet cells B2 and B3.
Worksheets("User Form").Range("B2").value = cell.value '<--| name is in current cell
Worksheets("User Form").Range("B3").value = cell.Offset(, 1).value '<--| date is in adjacent cell
'2. Enter country population and income level in Countries worksheet cells B1 and E1.
Worksheets("Table").Range("B1").value = cell.Offset(, 2).value '<--| population is in cell two columns right of current one
Worksheets("Table").Range("E1").value = cell.Offset(, 3).value '<--| income level is in cell three columns right of current one
'3. Insert country map JPG in User Form worksheet at cell A18
'(cannot get this to loop!).
'The following is just an example - it works,
'but without loop of course (inserts the named file correctly).
Worksheets("User Form").Activate
Range("A18").Select
ActiveSheet.Pictures.Insert _
"C:\temp\profiles\2017\Maps\EN JPGs\" _
& cell.value & "_EN.jpg"
'4. Save the workbook as CountryName.xlxs.
Worksheets.Copy '<--| copy current workbook worksheets to a new workbook
ActiveWorkbook.SaveAs Filename:="C:\temp\profiles\2017\Production\Batch_EN_1\" _
& wbName & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close
Next cell
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
where:
you have to adapt:
ActiveSheet.Pictures.Insert _
"C:\temp\profiles\2017\Maps\EN JPGs\" _
& cell.value & "_EN.jpg"
to your actual filenames and source path conventions
I changed section 4 (Save the workbook as CountryName.xlxs)
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
Here is my challenge. I try to copy and paste data based on Currency and Dates to a newly created Worksheets in the same Workbook. Each newly created Worksheet should be named by Currency and Date from the main source. I am stuck with dates and I am not sure how to add other currencies. Please advise. Thank you very much.
Option Explicit
Sub Create_Copy_of_JE_DATA_Split_By_Currency_AND_By_Date()
Dim draft As Worksheet
Dim curr_date As Worksheet
Dim LastRow
Dim LastColumn As Integer
Dim i
Dim drafttable As Object
Dim Curr As String
Dim transdate As Date
'Clean up previous data before start the macro
Application.DisplayAlerts = False
For Each i In ActiveWorkbook.Worksheets
If i.name = "Draft_Data" Then i.Delete
Next i
For Each i In ActiveWorkbook.Worksheets
If i.name = "Currency_Date" Then i.Delete
Next i
Application.DisplayAlerts = True
'Create a draft sheet to work with data
Sheets("JE_data").Select
Sheets("JE_data").Copy After:=Sheets(Sheets.count)
ActiveSheet.name = "Draft_Data"
Set draft = Sheets("Draft_Data")
LastRow = draft.Range("A1").End(xlDown).End(xlDown).End(xlUp).Row
LastColumn = draft.Range("A1").End(xlToRight).Column
'Copy Currency and Date data to find unique data
'It depends on your data structure, the original assumption was that column C is currency and column D is transaction Date
'The actual data structure is different - Currency is Column "P" and Date is Column "W",
'so I would have to delete Columns between them
Range("P2:W" & LastRow).Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.count)
ActiveSheet.name = "Currency_Date"
Set curr_date = Sheets("Currency_Date")
ActiveSheet.Paste
Application.CutCopyMode = False
With Sheets("Currency_Date")
.Columns("B:G").EntireColumn.Delete
.Range("$A$1:$B$" & LastRow).RemoveDuplicates Columns:=Array(1, 2), Header:=xlNo
End With
'ActiveSheet.Range("$A$1:$B$" & LastRow).RemoveDuplicates Columns:=Array(1, 2), Header:=xlNo
'Select Draft sheet and start filtering
draft.Select
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$W$" & LastRow), , xlYes).name = "Draft_table"
'so when I filter it, it will have the same format.
'it's upto you to choose the date format, :) I'm in Australia so I choose d/mm/yyyy
Columns("W:W").Select
Selection.NumberFormat = "d/mm/yyyy;#"
Set drafttable = draft.ListObjects("Draft_table")
'The idea is for each unique value of currency and date pair, we will filter this Draft 'table
'and copy the result to a new sheet then rename this sheet.
For i = 1 To Sheets("Currency_Date").Range("A1").End(xlDown).End(xlDown).End(xlUp).Row
Curr = curr_date.Range("A" & i).Value
transdate = curr_date.Range("B" & i).Value
draft.Select
drafttable.Range.AutoFilter Field:=16, Criteria1:=Curr
drafttable.Range.AutoFilter Field:=23, Criteria1:=transdate
drafttable.Range.AutoFilter Field:=23, Criteria1:="=" & transdate, Operator:=xlAnd
Range("Draft_table").SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.count)
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.name = Format(transdate, "MMM DD YYYY") & " " & Curr
Sheets("JE_Data").Select
Rows("1:1").Select
Selection.Copy
Sheets(Format(transdate, "MMM DD YYYY") & " " & Curr).Select
Rows("1:1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Cells.EntireColumn.AutoFit
'Prepare for next filter.
draft.ShowAllData
Next i
'draft.Delete
'curr_date.Delete
End Sub
I don't know how your data look like, so I use a simple data like below:
ID Name Currency Transaction_Date
1 A AUD 1/08/2014
2 B USD 2/08/2014
3 C GBP 4/08/2014
4 D JPY 10/09/2014
5 E AUD 4/08/2014
6 F USD 10/09/2014
7 A GBP 1/08/2014
8 B JPY 2/08/2014
9 C AUD 4/08/2014
10 D USD 10/09/2014
My idea is create a list of unique value (Currency,Transaction date), then using filter to get data with 2 criterial: Currency and Data. Doesn't matter how many rows you have, it should work the same.
Copy the filtered data to new sheet and rename this sheet to DATE & Currency as required.
When I test, this works perfectly
(I have not clean my code yet, so please modify it as you need)
Sub Create_Copy_of_JEDATA()
Dim draft, curr_date As Worksheet
Dim LastRow, LastColumn As Integer
'Clean up previous data before start the macro
Application.DisplayAlerts = False
For Each i In ActiveWorkbook.Worksheets
If i.Name = "Draft_Data" Then i.Delete
Next i
For Each i In ActiveWorkbook.Worksheets
If i.Name = "Currency_Date" Then i.Delete
Next i
Application.DisplayAlerts = True
'Create a draft sheet to work with data
Sheets("JE_data").Select
Sheets("JE_data").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = "Draft_Data"
Set draft = Sheets("Draft_Data")
LastRow = draft.Range("A1").End(xlDown).End(xlDown).End(xlUp).Row
LastColumn = draft.Range("A1").End(xlToRight).Column
'Copy Currency and Date data to find unique data
'Depend on your data structure, I assume that column C is currency and column D is transaction Date
Range("C2:D" & LastRow).Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "Currency_Date"
Set curr_date = Sheets("Currency_Date")
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveSheet.Range("$A$1:$B$" & LastRow).RemoveDuplicates Columns:=Array(1, 2), Header:=xlNo
'Select Draft sheet and start filtering
draft.Select
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$D$" & LastRow), , xlYes).Name = "Draft_table"
'so when I filter it, it will have the same format.
'it's upto you to choose the date format, :) I'm in Australia so I choose d/mm/yyyy
Columns("D:D").Select
Selection.NumberFormat = "d/mm/yyyy;#"
Set DraftTable = draft.ListObjects("Draft_table")
'The idea is for each unique value of currency and date pair, we will filter this Draft table
'and copy the result to a new sheet then rename this sheet.
For i = 1 To Sheets("Currency_Date").Range("A1").End(xlDown).End(xlDown).End(xlUp).Row
Curr = curr_date.Range("A" & i).Value
transdate = curr_date.Range("B" & i).Value
draft.Select
DraftTable.Range.AutoFilter Field:=3, Criteria1:=Curr
DraftTable.Range.AutoFilter Field:=4, Criteria1:="=" & transdate, Operator:=xlAnd
Range("Draft_table").SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.Name = Format(transdate, "MMM DD YYYY") & " " & Curr
Sheets("JE_Data").Select
Rows("1:1").Select
Selection.Copy
Sheets(Format(transdate, "MMM DD YYYY") & " " & Curr).Select
Rows("1:1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Cells.EntireColumn.AutoFit
'Prepare for next filter.
draft.ShowAllData
Next i
'draft.Delete
'curr_date.Delete
End Sub