I am working on automating some reports by pasting data from raw files into my Template called PA Reach. I have named a range "Sumrow" and I need VBA to autosum the numbers above in each of the loops after pasting the data in. Here is what I have and I'm getting errors:
Workbooks.Open datapath & datafile1 & OutputFileExt
Sheets("Rep").Activate
ActiveSheet.UsedRange.AutoFilter
For i = 1 To terrs_to_generate
Workbooks(builder).Sheets("Control").Activate
Range("Reportnum") = i
currfile = Range("CurrFile").Value
currterr = Range("CurrTerr").Value
currRep = Range("currRep").Value
terrname = Range("terrname").Value
DMName = Range("DMName").Value
TMStartDate = Range("TMstartdate").Value
'open template
Workbooks.Open templatepath & templatefile & OutputFileExt
Set currtemplatefile = ActiveWorkbook
Sheets("Control").Select
Sheets("control").Range("terrname") = terrname
Sheets("control").Range("repname") = currRep
Sheets("control").Range("reportdate") = reportdate
Sheets("control").Range("TMstartdate") = TMStartDate
Sheets("control").Range("DMName") = DMName
Sheets("control").Range("Territory") = currterr
Workbooks(datafile1 & OutputFileExt).Activate
Selection.AutoFilter field:=1, Criteria1:=currterr
Range("A1").Select
Range(Selection.Offset(1, 1).End(xlDown), Selection.End(xlToRight)).Copy
currtemplatefile.Activate
Sheets("PA Reach").Select
Range("pasterange").Select
Selection.PasteSpecial Paste:=xlPasteValues
currtemplatefile.Activate
Range("formatrow").Copy
Range("pasterange").Select
Range(Selection.End(xlToRight), Selection.End(xlDown).Offset(0, 0)).Select
Selection.PasteSpecial Paste:=xlPasteFormats
'Delete PasteRange
Range("pasterange").Select
Selection.EntireRow.Delete
'Value Range Sheet so no formulas show
ActiveSheet.UsedRange.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Range("A1").Select
Sheets("control").Delete
'need to add in sum total
Range("sumrow1").End(xlDown).Offset(1, 0) = "=Sum(" & Range("sumrow1").Address(True, True) & ")"
'save as and close
ActiveWorkbook.SaveAs Filename:=(reportpath & currfile & OutputFileExt) 'not working
There is no need to Select Range("sumrow"), and then use Selection, you can modify the Formula to the Range directly.
Try the code below, it will put the Sum formula at the row below the bottom row of your "sumrow" named range:
Range("sumrow").End(xlDown).Offset(1, 0) = "=Sum(" & Range("sumrow").Address(True, True) & ")"
Related
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)
Anyone,
I'm trying to make a program in excel vba in which the macro would look/loop for the sheet name in the workbook base on the excel range. Also, after looking for the sheet name, the program would save the sheet based on the given file name on the other cell range.
My main problem here is on how I can save the loop file/sheet name based on the teritory name given in the picture provided below.
Hope you can help me with my problem.
Here's my recent work on the macro, I can save the file but it saves the file based on the sheet name I have looked up. Thanks.
sample picture here
Sub Save_Test()
Dim ws As Worksheet
Dim wb As Workbook
Dim c, b As Range
Dim rng, rng2 As Range
Dim mysheet As Worksheet
Dim LastRow, LastRow2 As Integer
Dim file_name As String
LastRow = Range("I" & rows.Count).End(xlUp).row
Set rng = Range("J5:J" & LastRow)
Set ws = Worksheets("Control")
For Each c In rng
Sheets(c.Value).Select
Cells.Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Copy
Application.DisplayAlerts = False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
ActiveSheet.Name = c.Value
Application.CutCopyMode = False
ActiveWindow.DisplayGridlines = False
TemplateLocation = ThisWorkbook.Path
file_name = c.Value
ActiveWorkbook.SaveAs Filename:=TemplateLocation & "\" & "Reports" & "\" & Format(Now() - 1, "mmyy") & " " & file_name & " Hustle Board thru " & Format(Now() - 1, "mm-dd-yy"), FileFormat:=51, CreateBackup:=False
Application.DisplayAlerts = False
ActiveWindow.Close
Next
Sheets("Control").Select
End Sub
You will have to fill in the other stuff you need to do, but going off your picture and you code, this should get you the value in the teritory column
Dim r As Range
Dim rng As Range
Dim LastRow As Long
Dim ws As Worksheet
LastRow = Range("I" & Rows.Count).End(xlUp).Row
Set rng = Range("J5:J" & LastRow)
For Each r In rng
file_name = r.Offset(, -1)
ActiveWorkbook.SaveAs Filename:=TemplateLocation & "\" & "Reports" & "\" & Format(Now() - 1, "mmyy") & " " & file_name & " Hustle Board thru " & Format(Now() - 1, "mm-dd-yy"), FileFormat:=51, CreateBackup:=False
Next r
End Sub
BTW, if you did not already know, declaring varibales like this below is not good practice.
Dim rng, rng2 As Range
In this case rng is not a rng at this point. You need to do this below to explicitly declare as a Range variable.
Dim rng as Range, rng2 As Range
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 have 26 worksheets every week that contain a "Station #", "Latitude#", and a "Longitude#".
I want to create a Macro that grabs these 3 cells, copies them and places them into 3 columns named "Station #", "Lat", and "Long.
I'm not very good at this so i need some help.
This is what i got so far:
Sub Macro1()
FolderName = "C:\Users\Captain Wypij\Desktop\Traffic\test"
If Right(FolderName, 1) <> Application.PathSeparator Then FolderName = FolderName & Application.PathSeparator
Fname = Dir(FolderName & "*.xls")
'loop through the files
Do While Len(Fname)
With Workbooks.Open(FolderName & Fname)
Range("C8:D8").Select
Selection.Copy
ChDir "C:\Users\Captain Wypij\Desktop\Traffic"
Workbooks.Open Filename:= _
"C:\Users\Captain Wypij\Desktop\Traffic\Test.xls.xlsx"
Range("A2").Select
If ("A2") = "*" Then Range("A3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Workbooks.Open (FolderName & Fname)
ActiveWindow.SmallScroll Down:=12
Range("C34:D34").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Test.xls.xlsx").Activate
Range("B2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Workbooks.Open (FolderName & Fname)
Range("G34:H34").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Test.xls.xlsx").Activate
Range("C2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Workbooks.Open (FolderName & Fname)
ActiveWindow.Close
Windows("Test.xls.xlsx").Activate
ActiveWorkbook.Save
ActiveWindow.Close
End With
' go to the next file in the folder
Fname = Dir
Loop
End Sub
I cant seem to figure out how to paste the next worksheet i open in the next fields ( such as A3, B3, C3 and so forth.
Please help me!
Try this:
Dim FolderName As String, Fname As Variant
FolderName = "C:\Location\Folder\"
Fname = Dir(FolderName & "*.xlsx")
Dim wb As Workbook, ws As Worksheet, lr as long
Do While Fname <> ""
Set wb = Workbooks.Open(FolderName & Fname)
Set ws = wb.Sheets("SheetName") '~~> Change to suit
With Thisworkbook.Sheets("Sheet1") '~~> Change to suit
lr = .Range("A" & .Rows.Count).End(xlUp).Row + 1
ws.Range("C8:D8").Copy: .Range("A" & lr).PasteSpecial xlPasteValues
ws.Range("C34:D34").Copy: .Range("B" & lr).PasteSpecial xlPasteValues
ws.Range("G34:H34").Copy: .Range("C" & lr).PasteSpecial xlPasteValues
End With
wb.Close False
Set wb = Nothing: Set ws = Nothing
Fname = Dir
Loop
Above code basically opens all .xlsx file in the specified folder and then copies static ranges. This static ranges are the ones you specified in your question (e.g. Range("C8:D8")). So it copies it and paste it as values on the sheet you will specify. It finds the last row on the destination sheet which will put the copied values below it.
Is this what you're trying? HTH.
I wanted to do like this:
Work Book1 (
Sheet1 has:
ColA:
AA
AA
AA
AB
AB
AB
AC
AC
AC
AC
Now I need to count how many are AA's, AB's, AC's and so on and represent their numbers in ColB of Work book B (Sheet1) like this:
ColA: ColB:
AA 3
AB 3
AC 4
Here in this second work book Col A is already mentoined so need to filter or add or change Col A just to update Col (B).
With the help of users here is the code modified so far: but I need your input thank you!
Code:
Sub foo()
Dim x As Workbook
Dim y As Workbook
'# Openning both workbooks first:
Set x = Workbooks.Open("C:\Users\ax1jk3\Desktop\Workbooks\Book2")
Set y = Workbooks.Open("C:\Users\ax1jk3\Desktop\Workbooks\Book1")
'Navigate to the first WOrkBook
Windows("Book1").Activate
'Find all the Rown in Range A that you need to copy
Sheets("Sheet1").Range("A1:A" & Sheets("Sheet1").Rows.Count).End(xlUp).Rows.Select
Selection.Copy
'Navigate to the Other WOrkBook
Windows("Book2").Activate
Sheets("Sheet2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
'This will remove the Duplicates
ActiveSheet.Range("$A$1:$A$" & ActiveSheet.Rows.Count).End(xlUp).Rows.RemoveDuplicates Columns:=1, Header:=xlNo
Range("B1").Select
ActiveCell.FormulaR1C1 = "=COUNTIF([Book12]Sheet1!C1,RC[-1])"
Range("B1").Select
Selection.AutoFill Destination:=Range("B1:B" & Rows.Count).End(xlUp).Rows
Range("B1:B" & Rows.Count).End(xlUp).Rows.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'Close x:
x.Close
End Sub
Here's how I'd do it, using the RemoveDuplicates function:
'# Opening both workbooks first:
Set x = Workbooks.Open("C:\Users\ax1jk3\Desktop\Workbooks\Book2.xlsx")
Set y = Workbooks.Open("C:\Users\ax1jk3\Desktop\Workbooks\Book1.xlsx")
'Navigate to the first WorkBook
x.Sheets(1).Activate
'Copy-Paste column A to y.sheets(1)
lastRow_x = Range("A" & Rows.Count).End(xlUp).Row
Range("A1:A" & lastRow_x).Copy
'Paste and remove duplicates
y.Sheets(1).Activate
Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo 'if your column has a header, use xlYes
'Count number of occurences of each row from y in x
lastRow_y = Range("A" & Rows.Count).End(xlUp).Row
For each loopCell in Range("A1:A" & lastRow_y) 'A2 if you have a header
loopCell.Offset(0, 1) = Sheets(1).Evaluate("=COUNTIF([Book2.xlsx]Sheet1!A1:A" & lastRow_x & "," & loopCell.Address & ")")
next loopCell
'Close x:
x.Close SaveChanges:=xlNo
End Sub
I haven't tested it but it should be really quick!
From my own experience, I would avoid using the .copy feature. Instead I recommend using an array to identify a unique list of items.
'# Openning both workbooks first:
Set x = Workbooks.Open("C:\Users\ax1jk3\Desktop\Workbooks\Book2")
Set y = Workbooks.Open("C:\Users\ax1jk3\Desktop\Workbooks\Book1")
'Navigate to the first WOrkBook
Windows("Book1").Activate
Sheets("Sheet1").Select
'identify end of source tab
source_ROW = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
Do While Range("A" & source_ROW) = ""
source_ROW = source_ROW - 1
Loop
source_ROW_end = source_ROW
source_ROW_start = 3
'initialize unique value array
Dim unique_ARRAY() As String
ReDim unique_ARRAY(1 To 1)
unique_ARRAY(1) = Range("A" & source_ROW_start)
'identify unique list
For source_ROW = source_ROW_start To source_ROW_end
'initialize
source_record = Range("A" & source_ROW)
new_value = "dunno_yet"
For i = 1 To UBound(unique_ARRAY, 1)
If source_record = unique_ARRAY(i) Then
'value already exists in the array
new_value = "no"
'no need to continue searching
Exit For
End If
Next i
If new_value = "no" Then
'the source_record matched values already found in the array
'does nothing
Else
'a new source_record was found
'new_value = "yes"
'redimensionalize the array while preserving pre-existing values
ReDim Preserve unique_ARRAY(1 To UBound(unique_ARRAY) + 1)
'read the new value into the new upper bound of the array
unique_ARRAY(UBound(unique_ARRAY, 1)) = source_record
End If
Next source_ROW
'Navigate to the Other WOrkBook
Windows("Book2").Activate
Sheets("Sheet2").Select
'cycle through each item in the array
for i = 1 to UBound(unique_ARRAY)
'write values to book2
Range("A" & i) = unique_ARRAY(i)
Range("B" & i) = "=COUNTIF([Book1]Sheet1!C1,RC[-1])"
'convert formulas to values
Range("B" & i).Copy
Range("B" & i).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
next i
'Close x:
x.Close
End Sub
You may also consider adapting the array to count how many times a value appears. Then you can eliminate .PasteSpecial at the end.