I try to export single sheet as .txt file after refreshing querytable.
I don't want to use Workbooks.Add or .Copy and .PasteSpecial method.
So far, I've made this:
Do Until i = 5
With Sheets(2).QueryTables(1)
.Refresh BackgroundQuery:=False
End With
Sheets(2).SaveAs ThisWorkbook.path & filename & i & ".txt", _
FileFormat:=xlTextMSDOS, CreateBackup:=False
i = i + 1
Loop
On first loop this works great, but on second i get errors.
Ok, I know what went wrong. Here is my original code:
Sub test()
Dim filename As String
Dim i As Integer
filename = "test_txt"
i = 0
Do Until i = 5
With Sheets(2).QueryTables(1)
.Refresh BackgroundQuery:=False
End With
Sheets(3).SaveAs ThisWorkbook.Path & "\FOLDER\" & filename & i & ".txt", _
FileFormat:=xlTextMSDOS, CreateBackup:=False
i = i + 1
Loop
End Sub
Because i have ThisWorkbook.Path in loop, it changes every time I run it. Solution is simple - put ThisWorkbook.Path outsite the loop, like this:
Sub test()
Dim filename As String
Dim saveloc as String
Dim i As Integer
filename = "test_txt"
saveloc = ThisWorkbook.Path & "\FOLDER\"
i = 0
Do Until i = 5
With Sheets(2).QueryTables(1)
.Refresh BackgroundQuery:=False
End With
Sheets(3).SaveAs saveloc & filename & i & ".txt", _
FileFormat:=xlTextMSDOS, CreateBackup:=False
i = i + 1
Loop
End Sub
Thanks #David Zemens for help!
Assuming Sheets(2) is part of ThisWorkbook, try the following:
Dim sep As String
sep = Application.PathSeparator
With ThisWorkbook
Do Until i = 5
.Sheets(2).QueryTables(1).Refresh BackgroundQuery:=False
.Sheets(2).SaveAs .path & sep & filename & i & ".txt", _
FileFormat:=xlTextMSDOS, CreateBackup:=False
i = i + 1
Loop
End With
Related
Me again , I'm trying to code for spliting sheets in the xlsm file into the seperate sheet then save them in the same place with the xlsm file. the code as below:
Sub splitsheet()
Dim path As String
Dim cities
ReDim cities(1 To ThisWorkbook.Worksheets.Count)
Dim i As Long
Dim sh As Worksheet
path = ActiveWorkbook.path
For i = 1 To Worksheets.Count
cities(i) = Sheets(i).Name
ActiveWorkbook.SaveAs _
Filename:=path & "\" & Sheets(i).Name & ".xlsx"
'ActiveWorkbook.Close False
Next i
End Sub
The error in my photo below. Why it can not save as in "xlsx" extension , above code is work fine with "xlsm" extension
Filename:=path & "\" & Sheets(i).Name & ".xlsm" 'it can work fine with xlsm extension
My question is how can save as in "xlsx" extension in this case. All assist/explaination will be appriciated.
Please try this code.
Sub EachSheetToEachOwnWorkbook()
' 286
Dim Path As String
Dim Ws As Worksheet
Application.ScreenUpdating = False
Path = ThisWorkbook.Path & "\"
For Each Ws In ThisWorkbook.Worksheets
Ws.Copy
With ActiveWorkbook
.SaveAs Filename:=Path & Ws.Name & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook, _
CreateBackup:=False
.Close
End With
Next Ws
Application.ScreenUpdating = True
End Sub
I have 250 excel documents where I try to print a sheet for pdf. If I do it manually, it will be 4 pages, but if I use my code, it will be 7 pages long.
It's like it ignores the print area, and makes several blank pages.
Can any of you figure out the mistake?
Dim wb As Workbook
Dim xExtension As String: xExtension = "*.xls*"
Dim xFolder As String: xFolder = [MailFolder]
Dim xFile As String: xFile = Dir(xFolder & xExtension) 'DIR gets the first file of the folder
Dim Rng As Range: Set Rng = Range("A1")
Dim s As String
Do While xFile <> "" 'Loop through all files in a folder until DIR cannot find anymore
Set wb = Workbooks.Open(xFolder & xFile): wb.Activate
Call WorksheetsToPDF(wb, "F:\VBA\PDF\Udlejning\" & CleanFileName("Police - " & "2021 -" & [KompletPoliceNr] & " - " & [Forsikringstager]) & ".pdf", "Certifikat")
'Call WorksheetsToPDF(wb, "F:\VBA\KF Begæringer\" & CleanFileName("KF Begæring-2021-" & [KompletPoliceNr] & "-" & [Forsikringstager]) & ".pdf", "Police")
wb.Close savechanges:=False
xFile = Dir()
Loop
End Sub
Private Sub WorksheetsToPDF(wb As Workbook, DistinationPath As String, ParamArray Arr() As Variant)
wb.Sheets(Arr()).Select
Debug.Print EFDK.GetNextavailablefilename(DistinationPath)
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=EFDK.GetNextavailablefilename(DistinationPath), Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False
End Sub
Private Function GetNextAvailableFilename(ByVal xPath As String) As String
With CreateObject("Scripting.FileSystemObject")
Dim strFolder As String, strBaseName As String, strExt As String, i As Long
strFolder = .GetParentFolderName(xPath)
strBaseName = .GetBaseName(xPath)
strExt = .GetExtensionName(xPath)
Do While .FileExists(xPath)
i = i + 1
xPath = .BuildPath(strFolder, strBaseName & " - " & i & "." & strExt)
Loop
End With
GetNextAvailableFilename = xPath
End Function
You did not answer my clarification questions...
Just for the sake of testing, please try the next adapted function:
Private Sub WorksheetsToPDF(wb As Workbook, DistinationPath As String, ParamArray arr() As Variant)
Dim El
wb.Sheets(arr()).Select
For Each El In arr()
wb.Sheets(El).PageSetup.FitToPagesWide = 1
wb.Sheets(El).PageSetup.PaperSize = xlPaperA4 ' xlPaperLetter
wb.Sheets(El).PageSetup.Orientation = xlLandscape
Next
'Debug.Print EFDK.GetNextavailablefilename(DistinationPath)
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=EFDK.GetNextavailablefilename(DistinationPath), Quality:=xlQualityStandard, IncludeDocProperties:=True
End Sub
I need help copying data from a closed workbooks (without opening them) into a column in the master workbook using VBA. I keep getting the error:
Run-time Error 424: object required
Here is my code:
Set x = Workbooks.Open("C:\Users\DD\Desktop\EMS")
x.Sheets("PO Report").Range("Y3:Y500").Copy
y.Activate
Sheets("Sheet1").Range("Q2").PasteSpecial
Application.CutCopyMode = False
x.Close
Thanks for the help in advance!
this is the problem - you are not specifying the filename of the excel file
Set x = Workbooks.Open("C:\Users\DD\Desktop\EMS")
you cannot read data out of a closed file... it has to be open
you also need to Dim your x object
Dim x as object
I altered the code posted here. Insert the following code in your "Sheet1" sheet module:
Option Explicit
Sub GetDataDemo()
Dim FilePath$
Dim i As Long
Const FileName$ = "EMS.xlsx"
Const SheetName$ = "PO Report"
FilePath = "C:\Users\DD\Desktop\"
DoEvents
Application.ScreenUpdating = False
If Dir(FilePath & FileName) = Empty Then
MsgBox "The file " & FileName & " was not found", , "File Doesn't Exist"
Exit Sub
End If
For i = 3 To 500
Range("Q" & i - 1) = GetData(FilePath, FileName, SheetName, Range("Y" & i))
Next i
ActiveWindow.DisplayZeros = False
End Sub
Private Function GetData(Path, File, Sheet, Rng)
Dim Data$
Data = "'" & Path & "[" & File & "]" & Sheet & "'!" & Rng.Address(, , xlR1C1)
GetData = ExecuteExcel4Macro(Data)
End Function
I have a workbook with several sheets.
One of the sheets "Calc" summarizes the data for 8 spark lines I have presented on a summary page based on an employee ID number entered on the summary page.
I have a created DO-loop macro to run this summary sheet by employee ID# and convert to a PDF and save by ID number.
Works like a charm and saves hours of time (literally). Trouble is two of the spark lines will not update.
I feel like Excel going to fast to allow them to update.
I have tried to put in a delay, Application.Wait(Now + TimeValue("00:00:01")), and have gone up to two minutes... No luck. Any ideas?
Option Explicit
Sub PDFtool()
On Error GoTo errorHandle:
Dim i As Integer
i = 2
Dim main, dataname, path, filename, ID As String
path = Cells(5, 4)
main = ActiveWorkbook.Name
filename = ActiveWorkbook.path & "\" & "PDF files " & Format(Now(), "yyyy mm dd hh mm")
MkDir filename
Workbooks.Open filename:=path
dataname = ActiveWorkbook.Name
Do
Worksheets("AM Location & ID#").Activate
If Cells(i, 1) = "" Then Exit Do
ID = Cells(i, 3)
Worksheets("AM").Activate
Cells(190, 1) = ID
Worksheets("AM").Calculate
ActiveSheet.ListObjects("Table33").Range.AutoFilter Field:=1, Criteria1:= _
"TRUE"
Columns("H:N").Select
Selection.EntireColumn.Hidden = True
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
filename:=filename & "/" & ID & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
Columns("G:S").Select
Selection.EntireColumn.Hidden = False
ActiveSheet.ListObjects("Table33").Range.AutoFilter Field:=1
i = i + 1
Loop
Application.ScreenUpdating = True
End
errorHandle:
Application.ScreenUpdating = True
MsgBox ("ERROR! Call Greg")
End
End Sub
I'm pretty new to vba, and I could use some help.
Here is the code am using. This is just a basic macro to call another macro and loop. However, it seems to be skipping everything from workbooks.open through activeworkbook.saveas.
The annoying bit is that I have used this code twice before but with different file names and paths and everything worked.
I have stepped-through the code and it really just seems to be skipping those lines, which it does not do in the original code.
Sub oddball_macro_loop()
'
' oddball_macro_loop Macro
'
'
Dim rawPath As String
Dim rawFile As String
Dim savePath As String
Dim oWB As Workbook
Dim fName As Variant
rawPath = "I:\Cores\DMB\E-Prime Tasks\Salience Task\Data\Macros\Raw\For macro"
rawFile = Dir(rawPath & "*.txt")
savePath = "I:\Cores\DMB\E-Prime Tasks\Salience Task\Data\Macros\Processed"
ChDir (rawPath)
Application.DisplayAlerts = True
Do While rawFile <> ""
Workbooks.Open Filename:="I:\Cores\DMB\E-Prime Tasks\Salience Task\Data\Macros\oddball_macro.xlsm"
Set oWB = Workbooks.Open(rawPath & rawFile)
Application.Run "'oddball_macro.xlsm'!oddball_macro"
Sheets("Data").Select
'Sets File Name
Dim text As String
text = Range("Z12")
fName = Mid(text, 19)
ActiveWorkbook.SaveAs Filename:=savePath & fName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close False
rawFile = Dir()
Loop
ActiveWorkbook.Close False
Application.ScreenUpdating = True
End Sub
If it's skipping those lines then that suggests the result of the Dir() function is null.
it looks like you may be possibly missing a path separator at the end of rawPath? This should fix it:
rawFile = Dir(rawPath & Application.PathSeparator & "*.txt")
Or alternatively just make sure you add that to your assignment statment:
rawPath = "I:\Cores\DMB\E-Prime Tasks\Salience Task\Data\Macros\Raw\For macro\"
Often you'll see people do something like this as a sort of double-check:
If Not right(rawPath, 1) = Application.PathSeparator then
rawPath = rawPath & Application.PathSeparator
End If
rawFile = Dir(rawPath & "*.txt")
Or you could get real fancy and do this:
Dim sep as String
sep = Application.PathSeparator
rawFile = Dir(rawPath & IIF(Right(rawPath,1) = sep, "*.txt", sep & ".txt"))