I am not familiar with VBA so please forgive the simplicity of this question. I have a recorded macro which selects, opens then saves a file from a hyperlink in one of my columns. I just want to make a loop to repeat this macro down all of the rows in the worksheet which have data in them. Below is the code for the recorded macro, thank you all for your assistance.
Sub Extract()
'
'Extract Macro
'
'
Range("D2").Select
Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
Workbooks.Open Filename:= _
"https://channele.corp.etradegrp.com/communities/teams02/performance-monitoring/TPEF%20Library/A2Consulting_Tech_5650_VSAF.xlsm"
ActiveWindow.Visible = False
Windows("A2Consulting_Tech_5650_VSAF.xlsm").Visible = True
ChDir "O:\Procurement Planning\QA"
ActiveWorkbook.SaveAs Filename:= _
"O:\Procurement Planning\QA\Copy of A2Consulting_Tech_5650_VSAF.xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
ActiveWindow.Close
End Sub
Something like this might work already:
Sub Extract()
Dim RngTarget As Range
Dim StrFileName As String
Set RngTarget = Range("D2")
Do Until RngTarget.Value = ""
RngTarget.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
Workbooks.Open Filename:=RngTarget.Value
StrFileName = Split(RngTarget.Value, "/")(UBound(Split(RngTarget.Value, "/")))
Windows(StrFileName).Visible = True
Workbooks(StrFileName).SaveAs Filename:="O:\Procurement Planning\QA\Copy of " & Split(StrFileName, ".")(0) & ".xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, _
CreateBackup:=False
Workbooks(StrFileName).Close
Set RngTarget = RngTarget.Offset(1, 0)
Loop
End Sub
Related
How can I copy only the range of cells from A1 to J47 to a new worksheet, and not the whole sheet? Thank you
Sub Salva()
Dim X As String
X = "Foglio salvato n° " & Range("G3").Value
Sheets(1).Copy
ActiveWorkbook.SaveAs Filename:="C:\Users\wc074\Documents\archivi\" & X & ".xls", FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
ActiveWindow.Close
End Sub
Please, try the next code:
Sub Salva()
Dim X As String, sh As Worksheet, newWb As Workbook, rng As Range
Set sh = ActiveSheet
X = "Foglio salvato n° " & sh.Range("G3").value
Set rng = sh.Range("A1:J47")
Set newWb = Workbooks.Add
rng.Copy newWb.Sheets(1).Range("A1")
newWb.Sheets(1).UsedRange.EntireColumn.AutoFit
newWb.saveas FileName:="C:\Users\wc074\Documents\archivi\" & X & ".xls", FileFormat:=xlExcel8 'Excel 97-2003 Workbook
newWb.Close False
End Sub
I'm working on a Macro that makes several CSV files from a certain area while applying a filter. There are two issues.
The workbook will be saved as a file-format retrieved from it's name (cell B15 and the word 'Week')
I cannot find a way to loop this Macro until Cell B15 is empty.
Can anyone help? Thanks in advance.
Example wrong format:
Sub CSVMaker()
'
' CSVMaker Macro
'
'
ActiveSheet.Range("$A$17:$M$240000").AutoFilter Field:=2, Criteria1:="<>"
Range("A18:B18").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets.Add.Name = Range("A10").Value & "." & Range("A7").Value & "." & "Week" & Range("B15").Value
ActiveSheet.Paste
Application.CutCopyMode = False
Application.DisplayAlerts = False
ActiveSheet.Copy
ActiveWorkbook.SaveAs Filename:=ActiveSheet.Name, FileFormat:=xlCSV, CreateBackup:=True
ActiveWorkbook.Close
Application.DisplayAlerts = True
Sheets("Input").Select
Columns("B:B").Select
Range("B6").Activate
Selection.Delete Shift:=xlToLeft
End Sub
So finally the answer is the filename needs a correct extension like Filename:=ActiveSheet.Name & ".csv".
And I recommend to avoid .Select and do the following:
Option Explicit
Public Sub CSVMaker()
Dim ws As Worksheet
Set ws = ActiveSheet 'better ThisWorkbook.Worksheets("your-sheet-name")
ws.Range("$A$17:$M$240000").AutoFilter Field:=2, Criteria1:="<>"
ws.Range("A18:B18", ws.Range("A18:B18").End(xlDown).End(xlDown)).Copy
Dim SheetName As String
SheetName = ws.Range("A10").Value & "." & Range("A7").Value & "." & "Week" & Range("B15").Value
ThisWorkbook.Sheets.Add.Name = SheetName
ThisWorkbook.Sheets(SheetName).Paste
Application.CutCopyMode = False
Application.DisplayAlerts = False
ThisWorkbook.Sheets(SheetName).Copy
ActiveWorkbook.SaveAs Filename:=SheetName & ".csv", FileFormat:=xlCSV, CreateBackup:=True
ActiveWorkbook.Close
Application.DisplayAlerts = True
ThisWorkbook.Sheets("Input").Columns("B:B").Delete Shift:=xlToLeft
End Sub
I am trying to do page setup on multiple sheets with same range. However, one of the sheets "Dashboard" has different page set up range. It is going to be "D24:K73" How can I accomplish that with the code below? I have tried modifying it but my skills do not produce wanted results.
Sub Octsaveaspdf()
Dim ws As Worksheet
Dim FileName As String
Dim FilePath As String
For Each ws In Sheets
If ws.Visible Then ws.Select (False)
Next
FilePath = Range("Instructions!B16").Value
FileName = Range("Dashboard!Q26").Text
Range("$p24:$w73").Select
Application.PrintCommunication = False
With ActiveSheet.PageSetup
LeftMargin = Application.CentimetersToPoints(0.1)
.RightMargin = Application.CentimetersToPoints(0.1)
.FitToPagesWide = 1
End With
Application.PrintCommunication = True
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, FileName:=FilePath & "Compare " & FileName & ".pdf" _
, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
End Sub
I truly appreciate all the help :) Thank you!
Move your export into a separate procedure and call it multiple times with different ranges to export.
The code below will work through each visible sheet and export different ranges depending on the sheet name.
Each export will be given the same name, so you'll need to do something about that to stop problems with file name conflicts.
Private FilePath As String
Private FileName As String
Public Sub OctSaveAsPDF()
Dim ws As Worksheet
FilePath = ThisWorkbook.Worksheets("Instructions").Range("B16")
FileName = ThisWorkbook.Worksheets("Dashboard").Range("Q26")
For Each ws In ThisWorkbook.Worksheets
If ws.Visible Then
Select Case ws.Name
Case "Dashboard"
PerformExport ws.Range("D24:K73")
Case "Sheet1", "Sheet2"
PerformExport ws.Range("A1:Z10")
Case Else
PerformExport ws.Range("P24:W73")
End Select
End If
Next ws
End Sub
Public Sub PerformExport(xpRng As Range)
With xpRng
With .Parent.PageSetup 'The parent of the range is the worksheet.
.LeftMargin = Application.CentimetersToPoints(0.1)
.RightMargin = Application.CentimetersToPoints(0.1)
.FitToPagesWide = 1
End With
.ExportAsFixedFormat _
Type:=xlTypePDF _
, FileName:=FilePath & "Compare " & FileName & ".pdf" _
, Quality:=xlQualityStandard _
, IncludeDocProperties:=True _
, IgnorePrintAreas:=False _
, OpenAfterPublish:=True
End With
End Sub
I want to enhance my current VBA Macro which exports data from one place to another by removing all rows that have Zero Amount in column G. Can someone show me what VBA script i need to add in my current script to do this?
Here is my script now:
Sub ExportFees()
'
' ExportFees Macro
' Mgt Fee Import
'
Dim Filename As String
Filename = Worksheets("Tradar Import").Range("Y8")
Columns("A:W").Select
Selection.Copy
Workbooks.Add
Cells.Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:= _
"\\BET-SYD-SVR01\Betashares\Ops\Tradar Import\FEE001\" & Filename, FileFormat _
:=xlCSV, CreateBackup:=False
ActiveWorkbook.Save
ActiveWindow.Close
End Sub
Original Data Source
If you set a range reference to the data then you can use Range.AutoFilter to filter the data and Range.Copy to copy the filtered data to a destination range.
Sub ExportFees()
'
' ExportFees Macro
' Mgt Fee Import
'
Dim Filename As String
Dim DataRange As Range
Set DataRange = Range("A1").CurrentRegion
DataRange.AutoFilter Field:=7, Criteria1:="<>0", Operator:=xlAnd
DataRange.AutoFilter
Filename = Worksheets("Tradar Import").Range("Y8")
Workbooks.Add
DataRange.Copy Destination:=Range("A1")
ActiveWorkbook.SaveAs Filename:= _
"\\BET-SYD-SVR01\Betashares\Ops\Tradar Import\FEE001\" & Filename, FileFormat _
:=xlCSV, CreateBackup:=False
ActiveWorkbook.Save
ActiveWindow.Close
End Sub
I have this code, although it states there is an error.
What i want to do is complete csv file export from the current active sheet, and save it with the information currently in cell A2.
Sub exportCSV()
' export Macro
Range("A:F").Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
strName = AprilPayslips.Range("A2")
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & strName
, FileFormat:=xlCSV, CreateBackup:=False
Application.DisplayAlerts = False
Application.DisplayAlerts = True
End Sub
If you want the value of a cell as a string then ask for it :)
strName = Range("A2").Value
These two lines won't do anything as they stand, so remove them:
Application.DisplayAlerts = False
Application.DisplayAlerts = True
Paths should always include the trailing slash so you don't need to add that in:
Sub exportCSV()
strName = Range("A2").Value
Range("A:F").Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & strName, FileFormat:=xlCSV, CreateBackup:=False
End Sub
Should work for you, however unless you can be sure that the contents of A2 will always be a valid filename you may run into problems unless you add in some extra validation.