I am trying to create a macro which will open up an Excel file and run a macro in the newly opened file which will then generate a PowerPoint presentation, save the presentation, close the presentation, PowerPoint and the newly opened Excel file, then start the process and complete the process again with the next Excel file to be opened.
Process works fine for the first file but for the 2nd Excel file to be opened, it appears that the Application.Run code skips and so the process breaks at the Set PPPRes because there isn't a presentation to be made active as one isn't created in the Application.Run process.
Any suggestions as to why it might be breaking?
Sub CreatePowerPoints()
Dim wb As Workbook, wb1 As Workbook, PPApp As PowerPoint.Application, PPPRes As PowerPoint.Presentation
lr = Sheet1.Cells(Rows.Count, 2).End(xlUp).Row
Year1 = Right(Date, 4) - 1
Year2 = Right(Date, 4)
RepPer = Left(Sheet1.Range("REPPERIOD").Value, 3)
RepTem = Sheet1.Range("REPTEMPLATE")
Set wb1 = ThisWorkbook
For x = 6 To lr
ChkPath1b = wb1.Sheets("Tracking").Range("P" & x) & Year1 & "\" & wb1.Sheets("Tracking").Range("REPMONTH")
ChkPath2b = wb1.Sheets("Tracking").Range("P" & x) & Year2 & "\" & wb1.Sheets("Tracking").Range("REPMONTH")
If Sheet1.Range("J" & x) = "Yes" Then
Set wb1 = ThisWorkbook
wbName = wb1.Sheets("Tracking").Range("D" & x) & " - Client Engine.xlsm"
If RepPer = "Dec" Then
Filename = ChkPath1b & "\" & wbName
Set wb = Workbooks.Open(Filename, ReadOnly:=True)
End If
If RepPer <> "Dec" Then
Filename = ChkPath2b & "\" & wbName
Set wb = Workbooks.Open(Filename, ReadOnly:=True)
End If
Application.Run "'" & wbName & "'!SendToPPT"
Set PPApp = New PowerPoint.Application
Set PPPRes = PPApp.ActivePresentation
If RepPer = "Dec" Then
PPPRes.SaveAs ChkPath1b & "\" & wb1.Sheets("Tracking").Range("D" & x) & " - Monthly Report.pptm"
Else
PPPRes.SaveAs ChkPath2b & "\" & wb1.Sheets("Tracking").Range("D" & x) & " - Monthly Report.pptm"
End If
'wbName = Nothing
wb.Close False
PPPRes.Close
PPApp.Quit
wb1.Sheets("Tracking").Range("H" & x).Value = "REPORT CREATED"
wb1.Sheets("Tracking").Range("j" & x).Value = "No"
End If
Next x
MsgBox "All PowerPoints created."
End Sub
Related
I inherited VBA code that has not worked since my work updated our version of Excel.
The original code looped through all Excel files in a specific folder.
If data in specific cells was blank or a 0, would rename the whole workbook so I would know what files to delete after the fact.
This is the original code. I don't need it to do all of this anymore.
This is part one:
Sub AllFilesWeekly()
Dim folderPath As String
Dim filename As String
Dim wb As Workbook
folderPath = "C:\Users\" & (Environ$("Username")) & "\Desktop\Process Production\" 'change to suit
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
filename = Dir(folderPath & "*.xlsx")
Do While filename <> ""
Application.ScreenUpdating = False
Set wb = Workbooks.Open(folderPath & filename)
'Call a subroutine here to operate on the just-opened workbook
Call getmetrics
On Error Resume Next
If Not ActiveWorkbook.Name Like "Audit Hub Report Distribution*" Then
ActiveWorkbook.Close
End If
filename = Dir
Loop
Application.ScreenUpdating = True
End Sub
The second part:
Sub getmetrics()
Dim cell As Range
Dim procstring As String, wbname As String
'Dim OQAYTD As String
Dim OQAMTD As String
Dim ORLYTD As String
Dim ORLMTD As String
Dim DR As String
Dim Audits As Long
Dim permonth As String, peryear As String, permonthrl As String, peryearrl As String
Dim RS As Worksheet, AD As Worksheet, QD As Worksheet, ws As Worksheet, YN As Boolean
For Each ws In Worksheets
If ws.Name = "Audit Detail" Then
YN = True
End If
Next ws
If YN = True Then
ActiveWorkbook.Sheets(2).Name = ("Rep Summary")
Set RS = ActiveWorkbook.Sheets("Rep Summary")
Set AD = ActiveWorkbook.Sheets("Audit Detail")
Set QD = ActiveWorkbook.Sheets("Question Detail")
With Sheets("Process Summary")
For Each cell In Range(Range("A3"), Range("A9999").End(xlUp))
If cell.Value = "Record Level YTD" Then
ORLYTD = Range(cell.Address).Offset(0, 1).Value
Else
If cell.Value = "YTD Quality Average" Then
OQAYTD = Range(cell.Address).Offset(0, 1).Value
Else
If cell.Value = "Record Level Quality Average" Then
ORLMTD = Range(cell.Address).Offset(0, 1).Value
Else
If cell.Value = "Quality Average" Then
OQAMTD = Range(cell.Address).Offset(0, 1).Value
Else
If cell.Value = "Audits" Then
Audits = Range(cell.Address).Offset(0, 1).Value
End If
End If
End If
End If
End If
Next cell
End With
wbname = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4)
peryear = VBA.Format(OQAYTD, "Percent")
permonth = VBA.Format(OQAMTD, "Percent")
peryearrl = VBA.Format(ORLYTD, "Percent")
permonthrl = VBA.Format(ORLMTD, "Percent")
DR = Right(Sheets("Process Summary").Range("A2").Value, Len(Sheets("Process
Summary").Range("A2").Value) - 12)
RS.Range(RS.Range("A1"), RS.Range("IV1").End(xlToLeft)).AutoFilter
RS.Range(RS.Range("A1"), RS.Range("IV1").End(xlToLeft)).EntireColumn.AutoFit
AD.Range(AD.Range("A1"), AD.Range("IV1").End(xlToLeft)).AutoFilter
AD.Range(AD.Range("A1"), AD.Range("IV1").End(xlToLeft)).EntireColumn.AutoFit
QD.Range(QD.Range("A1"), QD.Range("IV1").End(xlToLeft)).AutoFilter
QD.Range(QD.Range("A1"), QD.Range("IV1").End(xlToLeft)).EntireColumn.AutoFit
Application.DisplayAlerts = False
procstring = wbname & "|" & permonth & "|" & Audits & "|" & peryear & "|" & permonthrl & "|" &
peryearrl & "|" & DR ' & "|" & Users
Debug.Print procstring
Else
Application.DisplayAlerts = False
Dim AWN As String
AWN = ActiveWorkbook.FullName
Debug.Print "Not Audited: " & ActiveWorkbook.Name
ActiveWorkbook.SaveAs "C:\Users\" & (Environ$("Username")) & "\Desktop\Process Production\Delete -" & Second(Now)
Kill AWN
ActiveWorkbook.Close savechanges:=True
Application.DisplayAlerts = True
End If
End Sub
All I need to do is look at cell D3 on the "Process Summary" tab.
If the value in that space is "0.00%", rename the workbook to delete and loop on until all workbooks are looked at.
I do not need to screen print all the extra numbers any more.
Build a Collection of filenames that match the criteria and then use it to rename the files.
Option Explicit
Sub AllFilesWeekly()
Dim folderPath As String, filename As String
Dim wb As Workbook, ws As Worksheet
Dim col As Collection, n As Long
Set col = New Collection
folderPath = "C:\Users\" & (Environ$("Username")) & "\Desktop\Process Production\" 'change to suit
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
' scan folder
filename = Dir(folderPath & "*.xlsx")
Do While filename <> ""
Set wb = Workbooks.Open(folderPath & filename, True, True) ' update links, readonly
For Each ws In wb.Sheets
If ws.Name = "Process Summary" Then
If Format(ws.Range("D3"), "0.00%") = "0.00%" Then
col.Add wb.Name
End If
End If
Next
wb.Close
n = n + 1
filename = Dir
Loop
' result
MsgBox "Files scanned = " & n & vbCrLf & _
"To delete = " & col.Count, vbInformation, folderPath
' rename
If col.Count > 0 Then
If MsgBox("Continue to rename ?", vbYesNo) = vbYes Then
For n = 1 To col.Count
Name folderPath & col(n) As folderPath & "delete_" & col(n)
Next
MsgBox "Rename done"
End If
End If
End Sub
I have written this code and it has worked until now.
I have put two AutoFilter to pull certain rows. How do I amend the code to copy and paste visible rows?
I tried
Set TempRng = TempSH.Range("A1:DA" & TempSH.Range("B" & TempSH.Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy'
which copies the cells but then I get an error. Object required
Sub LoopThrough()
Dim MyFile As String, Str As String, MyDir As String
Dim sh As Worksheet, MasterRange As Range, TempWB As Workbook, TempSH As Worksheet, TempRng As Range
Dim NewMasterLine As Long
On Error GoTo ErrorHandler
Set sh = ThisWorkbook.Worksheets("Sheet2")
MyDir = "C:\Users\eldri\OneDrive\Desktop\New folder (2)\"
MyFile = Dir(MyDir & "*.xls")
ChDir MyDir
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While MyFile <> ""
'opens excel
Set TempWB = Workbooks.Open(FileName:=MyFile, UpdateLinks:=False,
Password:=CalcPassword(MyFile))
Set TempSH = TempWB.Worksheets(1)
Columns(1).Insert
Range("c2").Copy Range("A4:A10000")
Worksheets("Data").Range("A4").AutoFilter Field:=3, Criteria1:="AMS"
Worksheets("Data").Range("A4").AutoFilter Field:=4, Criteria1:="XNE"
Set TempRng = TempSH.Range("A1:DA" & TempSH.Range("B" & TempSH.Rows.Count).End(xlUp).Row)
NewMasterLine = sh.Range("B" & sh.Rows.Count).End(xlUp).Row
If NewMasterLine > 1 Then NewMasterLine = NewMasterLine + 1
Set MasterRange = sh.Range("A" & NewMasterLine & ":CW" & (NewMasterLine + TempRng.Rows.Count))
MasterRange.Value = TempRng.Value
'Debug.Print "Imported File: " & MyFile & ", Imported Range: " & TempRng.Address & ", Destination Range: " & MasterRange.Address
TempWB.Close savechanges:=False
MyFile = Dir()
Loop
MsgBox ("Done")
ErrorHandler:
If Err.Number <> 0 Then MsgBox "An error occurred." & vbNewLine & vbNewLine & "Last file that was attempted to be opened: " & MyFile & vbNewLine & vbNewLine & Err.Description
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
You cannot use Set and .Copy in one line.
First you need to set your range of visible cells:
Set TempRng = TempSH.Range("A1:DA" & TempSH.Range("B" & TempSH.Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible)
Then you need to test if there were visible cells found and if so you can copy them:
If Not TempRng Is Nothing Then
TempRng.Copy
'all code that relies on the copied range `TempRng` needs to go here
Else
MsgBox "No visible cells found!"
End If
I rewrote the code with the advice from #PEH and it worked - Please find the new code below.
Sub LoopThrough()
Dim MyFile As String, Str As String, MyDir As String
Dim sh As Worksheet, MasterRange As Range, TempWB As Workbook, TempSH As Worksheet, TempRng As Range, TempRow As Range
Dim NewMasterLine As Long
On Error GoTo ErrorHandler
Set sh = ThisWorkbook.Worksheets("Sheet2")
' Change address to suite
MyDir = "C:\Users\eldri\OneDrive\Desktop\W220Q1\"
MyFile = Dir(MyDir & "*.xls")
ChDir MyDir
' The following lines will put excel in a state similar to "frozen" mode. This will increase the code performance, as CPU will solely focus on performing
' the operations required by the code and not on showing the changes happening on excel
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' Here starts the loop related to the files in folder
Do While MyFile <> ""
'TempWB is a Worksheet object - will be the importing worksheet. TempRng is the used range in sheet 1 of the workbook
Set TempWB = Workbooks.Open(FileName:=MyFile, UpdateLinks:=False, Password:=CalcPassword(MyFile))
Columns(1).Insert
Range("c2").Copy Range("A4:A10000")
Set TempSH = TempWB.Worksheets(1)
Set TempRng = TempSH.Range("A1:DA" & TempSH.Range("A" & TempSH.Rows.Count).End(xlUp).Row)
'NewMasterLine is the last used row (+1) of the Master Workbook (It is basically where the new rows wiill start to be imported)
NewMasterLine = sh.Range("A" & sh.Rows.Count).End(xlUp).Row
If NewMasterLine > 1 Then NewMasterLine = NewMasterLine + 1
'This will loop through all the rows of the range to be imported, checking the first column.
' If the value in the second column is work-xne-ams, will import the single row in the master worklbook
For Each TempRow In TempRng.Rows
If TempRow.Cells(1, 3).Value = "AMS" And TempRow.Cells(1, 4).Value = "XNE" Or TempRow.Row < 4 Then
Set MasterRange = sh.Range("A" & NewMasterLine & ":CW" & NewMasterLine)
MasterRange.Value = TempRow.Value
NewMasterLine = NewMasterLine + 1
End If
Next
TempWB.Close savechanges:=False
MyFile = Dir()
Loop
MsgBox ("Done")
ErrorHandler:
If Err.Number <> 0 Then MsgBox "An error occurred." & vbNewLine & vbNewLine & "Last file that was attempted to be opened: " & MyFile & vbNewLine & vbNewLine & Err.Description
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Function CalcPassword(FileName As String) As String
CalcPassword = ""
On Error Resume Next
Dim TheFile As String: TheFile = Split(Split(FileName, "\")(UBound(Split(FileName, "\"))), ".")(0)
Dim PWD As Range: Set PWD = ThisWorkbook.Worksheets("PWD").ListObjects("PWD").DataBodyRange
CalcPassword = WorksheetFunction.VLookup(TheFile, PWD, 5, False)
End Function
I have 2 questions with my coding. Please bear with me since I'm not an expert on this.
Ws2.range("B6:Y" & lrow1).copy - doesn't seem to work the way I wanted it to be. It copies cells only from B1:Y6 but the intention is to copy cells starting ffrom B6:Y until the last row.
Dir Do while loops only on one file even though I have multiple files on the specified folder path. Thus, creating an infinite loop.
Any idea on what am I doing wrong?
Private Sub conso()
Dim folder As String, consofolder As String
Dim files As String, consofile As String
Dim dateyear As String, team As String
Dim strfile As String, newdate As String
Dim wb1 As Workbook, wb2 As Workbook
Dim lrow1 As Long, lrow2 As Long
Dim ws1 As Worksheet, ws2 As Worksheet
dateyear = Range("A2").Value
newdate = Format(dateyear, "mmmm yyyy")
team = Range("B2").Value
folder = Range("C2").Value
consofolder = folder & newdate & "\" & team
consofile = "conso "
files = Dir(consofolder & "\*.xlsm")
strfile = consofolder & "\" & consofile & team & " - " & newdate & ".xlsm"
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Application.AutomationSecurity = msoAutomationSecurityLow
Workbooks.Open Filename:=folder & "\" & "conso conso" & ".xlsm"
Set wb1 = Workbooks("conso conso.xlsm")
wb1.Activate
Set ws1 = wb1.Worksheets("Input")
If Len(Dir(strfile)) = 0 Then
GoTo conso
Else
MsgBox "Conso already in place"
Exit Sub
End If
conso:
Do While files <> ""
Debug.Print files
Workbooks.Open Filename:=consofolder & "\" & files
Set wb2 = Workbooks(files)
Set ws2 = wb2.Worksheets("Input")
With wb2
With Worksheets("Input")
lrow1 = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
End With
ws2.Range("B6:Y" & lrow1).Copy
wb1.Activate
With wb1
With Worksheets("Input")
lrow2 = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
End With
ws1.Range("B" & lrow2).PasteSpecial
wb2.Close
files = Dir(consofolder & "\*.xlsm")
Set wb2 = Nothing
Loop
End Sub
I have around 950 .xml files in a directory. I can open the .xml files with Excel without any issues. But I'd like to convert all files individually to .xls (or .csv). I searched the forum and found a few answers (see e.g. here and here) but could not make it work so far.
The closest I got to what I need is the following code:
Sub xmltoxl()
Dim f As String
Dim wbk As Workbook
Dim s As Integer
Dim tBook As Workbook
Dim MySht As Worksheet
Set tBook = ThisWorkbook
Set MySht = tBook.Sheets(1)
MySht.Cells.ClearContents
f = Dir("C:\Users\Kanye\Downloads" & "\*.xml")
s = 0
Do While Len(f) > 0
Set wbk = Workbooks.OpenXML("C:\Users\Kanye\Downloads" & "\" & f)
If s = 0 Then
wbk.Sheets(1).Cells.Copy Destination:=MySht.Cells
LastRow = MySht.Range("A" & Rows.Count).End(xlUp).Row
MySht.Range("Z1:Z" & LastRow) = f
Else
LastRow = MySht.Range("A" & Rows.Count).End(xlUp).Row
NextRow = LastRow + 1
wbkLastRow = wbk.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
wbk.Sheets(1).Rows("1:" & wbkLastRow).Copy Destination:=MySht.Rows(NextRow)
NewLastRow = MySht.Range("A" & Rows.Count).End(xlUp).Row
MySht.Range("Z" & NextRow & ":Z" & NewLastRow) = f
End If
MySht.Columns("Z").Cut
MySht.Columns("A").Insert
s = s + 1
wbk.SaveAs Filename:="C:\Users\Kanye\Downloads\Test" & s & ".csv"
wbk.Close False
f = Dir()
Loop
End Sub
However, when I run it, I get back an error after the first .xml is opened in the directory. Any ideas on how to solve this?
Try this code
Sub XMLTOCSV()
Dim f As String
Dim p As String
Dim s As Integer
p = Environ("USERPROFILE") & "\Downloads" & "\"
f = Dir(p & "*.xml")
s = 0
Application.ScreenUpdating = False
Do While Len(f) > 0
s = s + 1
ConvertXMLtoCSV p & f, p & "Test" & s & ".csv"
f = Dir()
Loop
Application.ScreenUpdating = True
End Sub
Sub ConvertXMLtoCSV(xmlFile, csvFile)
Dim xlApp As Application
Dim xlBook As Workbook
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.OpenXML(xmlFile, 2)
xlBook.SaveAs csvFile, 6
xlBook.Close False
xlApp.Quit
End Sub
I've found the most effective method of Workbook.SaveAs is to ignore any extension and let the FileFormat argument choose that for you.
...
wbk.SaveAs Filename:="C:\Users\Kanye\Downloads\Test" & s, fileformat:=xlcsv
wbk.Close savechanges:=False
...
I am getting a subscript out of range error when another user runs my add in but have no problems when running the same code myself. This happens when setting a workbook value. The filename is being generated by getting the current date and stored as gendate. From this, the filename is created and saved based on the filepath that the user has made. In this example, the value of gv.Range("b2").text is C:\Users\username\Desktop\ReportGeneration. fp is therefore C:\Users\dmulhausen\Desktop\ReportGeneration\TSReports9_6_201615h5m32s.xlsx
This is not generating an error for me, but it is generating an error for another user of the script.
Dim ai As Workbook 'add in data ---Initialized in Report Setup
Dim dwb As Workbook 'destination workbook ---Initialized in Report Setup
Dim ss As Worksheet 'source sheet
Dim ds As Worksheet 'destination sheet or writing sheet
Dim rv As Worksheet 'reporting variables sheet ---Initialized in Report Setup
Dim pv As Worksheet 'ts variables sheet ---Initialized in Report Setup
Dim gv As Worksheet 'global ai variables ---Initialized in Report Setup
Dim tempstr As String
Dim fp As String 'file path ---Initialized in Report Setup
Dim gendate As Date
Dim reportscreated As Integer
Dim initialized As Boolean
Dim sheetnames(1 To 12) As String
Sub reportsetup()
Set ai = Workbooks("TSReports add in.xlam")
Set rv = ai.Worksheets("ReportVars")
Set pv = ai.Worksheets("TS1_2Vars")
Set gv = ai.Worksheets("globalVars")
If (IsEmpty(gv.Range("b2").Value)) Then
MsgBox ("Please select a designated folder for reports")
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
If .SelectedItems.Count > 0 Then
gv.Range("b2").Value = .SelectedItems(1)
End If
ai.Save
End With
End If
initialized = True
gendate = Now()
tempstr = "TSReports" & Month(gendate) & "_" & Day(gendate) & "_" & Year(gendate) & Hour(gendate) & "h" & Minute(gendate) & "m" & Second(gendate) & "s"
fp = gv.Range("b2").Text & "\" & tempstr & ".xlsx"
Workbooks.Add
Application.DisplayAlerts = False
Application.AlertBeforeOverwriting = False
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=fp
Set dwb = Workbooks(tempstr) '*******Error occurs here*******
See: Windows().Activate works on every computer except one
This should fix the issue.
tempstr = "TSReports" & Month(gendate) & "_" & Day(gendate) & "_" & _
Year(gendate) & Hour(gendate) & "h" & Minute(gendate) & "m" & _
Second(gendate) & "s" & ".xlsx"
fp = gv.Range("b2").Text & "\" & tempstr
Workbooks.Add
Application.DisplayAlerts = False
Application.AlertBeforeOverwriting = False
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=fp
Set dwb = Workbooks(tempstr)
However this would be more robust:
Set dwb = Workbooks.Add
Application.DisplayAlerts = False
Application.AlertBeforeOverwriting = False
Application.DisplayAlerts = False
dwb.SaveAs Filename:=fp