I created MACRO in my order calculation template to deleted some unnecessary rows and save a sheet as workbook with "name". MACRO works great, but where is one annoying problem, I every time have change it this workbook name according to order number. So, I want to create/improve my MACRO to save sheet as workbook with cell name (this cell range "G1").
Could someone have ideas how to do this?
Sub Pirmoji()
'
' Pirmoji Macro
Sheets("Svorio Patvirtinimo dok").Select
ActiveSheet.Shapes.Range(Array("Column1")).Select
Sheets("Svorio Patvirtinimo dok").Copy
Rows("1:6").Select
Selection.Delete Shift:=xlUp
ActiveWindow.SmallScroll Down:=66
Dim LastRow As Long, myCell As Range, myRange As Range
Dim myCell1 As Range
LastRow = ActiveCell.SpecialCells(xlCellTypeLastCell).Row
Set myCell1 = Range("A" & LastRow)
Cells.Find(What:="• Praau atkreipti d?mes?:", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False).Activate
Set myCell = ActiveCell
Set myRange = Range(myCell, myCell1)
myRange.EntireRow.Delete
ActiveWindow.SmallScroll Down:=-78
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Copy
MsgBox "This new workbook will be saved as MyWb.xls(x)"
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\MyWb", xlWorkbookNormal
MsgBox "It is saved as " & ActiveWorkbook.FullName & vbLf & "Press OK to close it"
ActiveWorkbook.Close False
End Sub
The code below will fix only the relevant part of your post, how to save "Svorio Patvirtinimo dok" sheet as a new workbook, and file name according to the value in "G1".
You can do a lot of improvements also in the upper section of your code, there are a lot of unnecessary Select, Selection and ActiveCell.
Read HERE why you should avoid using Select, Activate and other similar types.
Modified Code (relevant section only):
Dim Sht As Worksheet
Dim NewWBName As String
' set the worksheet object
Set Sht = ThisWorkbook.Sheets("Svorio Patvirtinimo dok")
MsgBox "This new workbook will be saved as MyWb.xls(x)"
' set the bnew name in same path and file name according to the value in "G1"
NewWBName = ThisWorkbook.Path & "\" & Sht.Range("G1").Value2 & ".xlsx"
'save sheet as workbook with the name in cell "G1"
Sht.SaveAs NewWBName, 51 ' save format 51 - .xlsx
MsgBox "It is saved as " & NewWBName & vbLf & "Press OK to close it"
ActiveWorkbook.Close False
Related
I am new to VBA and I am trying to create a macro to which I will make a button out of to make a Pivot Table from data that I paste into a certain sheet.
The code below is from a macro that I tried to produce step-by-step of how I want the code to run.
I am selecting certain data (Columns A:G), then pasting that data into another sheet and then creating a blank table.
My code:
Sub Macro2()
'
' Macro2 Macro
'
'
Cells.Select
Range("A672198").Activate
Application.CutCopyMode = False
Selection.Copy
Application.CutCopyMode = False
Sheets.Add
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
"Sheet2!R1C1:R1048576C7", Version:=xlPivotTableVersion15).CreatePivotTable _
TableDestination:="Sheet11!R3C1", TableName:="PivotTable6", DefaultVersion _
:=xlPivotTableVersion15
Sheets("Sheet11").Select
Cells(3, 1).Select
End Sub
The issue comes from:
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
"Sheet2!R1C1:R1048576C7", Version:=xlPivotTableVersion15).CreatePivotTable _
TableDestination:="Sheet11!R3C1", TableName:="PivotTable6", DefaultVersion _
:=xlPivotTableVersion15
with an error message of:
Run-time error '5': invalid procedure call or argument
I have tried researching how to make a basic macro to create a blank pivot table of my data but I can't seem to figure it out.
I have also looked at many posts from this site and nothing really helped. I tried referencing this post but no luck.
I am using Microsoft Excel 2013*
Give this a shot - this will take columns A:G from Sheet1 and create a new sheet (named whatever), paste all the data into columns A:G on that sheet, then create a third sheet and create a new pivot table based on the data from sheet 2.
Option Explicit
Sub Test()
Dim sht1 As Worksheet, sht2 As Worksheet, sht3 As Worksheet
Dim lastrow As Long
Set sht1 = ThisWorkbook.Worksheets("Sheet1")
lastrow = sht1.Cells(sht1.Rows.Count, "A").End(xlUp).Row
Set sht2 = Sheets.Add(After:=Sheets(Sheets.Count))
Set sht3 = Sheets.Add(After:=Sheets(Sheets.Count))
sht2.Range("A1:G" & lastrow).Value = _
sht1.Range("A1:G" & lastrow).Value
ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
sht2.Name & "!R1C1:R" & lastrow & "C7", Version:=6).CreatePivotTable TableDestination:= _
sht3.Name & "!R3C1", DefaultVersion:=6
End Sub
Try this:
Sub create_pivot()
Dim mysourcedata, mydestination As String
Dim lr As Long
lr = Sheets("Sheet1").Range("A1").End(xlDown).Row '' find your last row with data
mysourcedata = "Sheet1!R1C1:R" & lr & "C5"
mydestination = "Sheet2!R1C1"
Sheets("Sheet2").Select
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, sourcedata:= _
mysourcedata, Version:=6).CreatePivotTable TableDestination:= _
mydestination, TableName:="PivotTable1", DefaultVersion:=6
End Sub
firstly, I'm having error running the code from Excel workbook directly. It leads to the error message mentioned below
We looked at all the data next to your selection and didn't see a pattern for filling in values for you. To use Flash Fill, enter a couple of examples of the output you'd like to see, keep the active cell in the column you want filled in and click the Flash Fill button again
However, I could run the code if is played from VBA windows under the developers tab. But Is limited to only 1 run before an error message 1004 pops up and also code error when played again.
Please help. Never taught or learnt VBA in ever. Code below is a mash up of researched on the net and trial & error.
Sub Graph()
'
' Graph Macro
'
' Keyboard Shortcut: Ctrl+e
'
'Select values in a column from specified workbook and sheet
Dim LR As Long, cell As Range, rng As Range
Windows("Area3-LG").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
'Error with rng.select when Macro is runned again
rng.Select
End With
Selection.Copy
'Open next workbook
Windows("InstData_TEMS_Existing").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("Area3-LG").Activate
Sheets("Graph data").Select
Columns("B:B").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Sheets("Graph Data").Select
End Sub
Thanks in advance (:
Try the code below, without all the unnecessary Select, Activate, and Selection:
Sub Graph()
'
' Graph Macro
'
' Keyboard Shortcut: Ctrl+e
'
'Select values in a column from specified workbook and sheet
Dim LR As Long, cell As Range, rng As Range
With Workbooks("Area3-LG").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
End With
rng.Copy ' copy the union range (no need to select it first)
' paste without all the selecting
With Windows("InstData_TEMS_Existing").Sheets("L")
' Paste (without select) un the next empty cell fromn column AA
.Range("AA" & .Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End With
Application.CutCopyMode = False
'Go back to previous workbook & delete column
Workbooks("Area3-LG").Sheets("Graph data").Columns("B:B").Delete Shift:=xlToLeft
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)
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
Have developed code with exact examples on this website, yet will not run and stops at SaveAs... line. Can anyone spot my mistake?
I get this error:
Yet the path C:\dads\Downloads\ does exist, the file is not in use by another program, and it has a different name. What am I missing?
Option Explicit
Sub PickupRoutes_Click()
Dim Rng As Range
Dim Lrow As Integer, NewFile As String
Lrow = 7
Set Rng = ActiveSheet.Range(Cells(2, 33), Cells(Lrow, 38))
'~~> Copy the range from the current Workbook
Rng.Select
Rng.Copy
'Establish a new Workbook and paste range
Application.Workbooks.Add
ActiveWorkbook.ActiveSheet.Range("A1").Select
'~~> Paste rng in Cell A1.
ActiveWorkbook.ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'~~>. Save the file
NewFile = "C:\dads\Downloads\" & "PlanMyRoute_" & _
Format(Date, "mm-dd-yyyy") & ".xlsm"
ActiveWorkbook.SaveAs NewFile, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
ActiveWorkbook.Close SaveChanges:=False
MsgBox "PlanMyRoute file has been saved "
End Sub
If the file path doesn't exist the error message will tack on what looks like a memory address which is why the error message and the code don't match.
It appears you are missing the Users directory in the path.
Change to:
NewFile = "C:\Users\dads\Downloads\" & "PlanMyRoute_" & _
Format(Date, "mm-dd-yyyy") & ".xlsm"