Copy data from closed workbook based on variable user defined path - vba

I have exhausted my search capabilities looking for a solution to this. Here is an outline of what I would like to do:
User opens macro-enabled Excel file
Immediate prompt displays for user to enter or select file path of desired workbooks. They will need to select two files, and the file names may not be consistent
After entering the file locations, the first worksheet from the first file selection will be copied to the first worksheet of the macro-enabled workbook, and the first worksheet of the second file selection will be copied to the second worksheet of the macro-enabled workbook.
I've come across some references to ADO, but I am really not familiar with that yet.
Edit: I have found a code to import data from a closed file. I will need to tweak the range to return the variable results.
Private Function GetValue(path, file, sheet, ref)
path = "C:\Users\crathbun\Desktop"
file = "test.xlsx"
sheet = "Sheet1"
ref = "A1:R30"
' Retrieves a value from a closed workbook
Dim arg As String
' Make sure the file exists
If Right(path, 1) <> "\" Then path = path & "\"
If Dir(path & file) = "" Then
GetValue = "File Not Found"
Exit Function
End If
' Create the argument
arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
Range(ref).Range("A1").Address(, , xlR1C1)
' Execute an XLM macro
GetValue = ExecuteExcel4Macro(arg)
End Function
Sub TestGetValue()
path = "C:\Users\crathbun\Desktop"
file = "test"
sheet = "Sheet1"
Application.ScreenUpdating = False
For r = 1 To 30
For C = 1 To 18
a = Cells(r, C).Address
Cells(r, C) = GetValue(path, file, sheet, a)
Next C
Next r
Application.ScreenUpdating = True
End Sub
Now, I need a command button or userform that will immediately prompt the user to define a file path, and import the data from that file.

I don't mind if the files are opened during process. I just didn't want the user to have to open the files individually. I just need them to be able to select or navigate to the desired files
Here is a basic code. This code asks user to select two files and then imports the relevant sheet into the current workbook. I have given two options. Take your pick :)
TRIED AND TESTED
OPTION 1 (Import the Sheets directly instead of copying into sheet1 and 2)
Option Explicit
Sub Sample()
Dim wb1 As Workbook, wb2 As Workbook
Dim Ret1, Ret2
Set wb1 = ActiveWorkbook
'~~> Get the first File
Ret1 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
, "Please select first file")
If Ret1 = False Then Exit Sub
'~~> Get the 2nd File
Ret2 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
, "Please select Second file")
If Ret2 = False Then Exit Sub
Set wb2 = Workbooks.Open(Ret1)
wb2.Sheets(1).Copy Before:=wb1.Sheets(1)
ActiveSheet.Name = "Blah Blah 1"
wb2.Close SaveChanges:=False
Set wb2 = Workbooks.Open(Ret2)
wb2.Sheets(1).Copy After:=wb1.Sheets(1)
ActiveSheet.Name = "Blah Blah 2"
wb2.Close SaveChanges:=False
Set wb2 = Nothing
Set wb1 = Nothing
End Sub
OPTION 2 (Import the Sheets contents into sheet1 and 2)
Option Explicit
Sub Sample()
Dim wb1 As Workbook, wb2 As Workbook
Dim Ret1, Ret2
Set wb1 = ActiveWorkbook
'~~> Get the first File
Ret1 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
, "Please select first file")
If Ret1 = False Then Exit Sub
'~~> Get the 2nd File
Ret2 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
, "Please select Second file")
If Ret2 = False Then Exit Sub
Set wb2 = Workbooks.Open(Ret1)
wb2.Sheets(1).Cells.Copy wb1.Sheets(1).Cells
wb2.Close SaveChanges:=False
Set wb2 = Workbooks.Open(Ret2)
wb2.Sheets(1).Cells.Copy wb1.Sheets(2).Cells
wb2.Close SaveChanges:=False
Set wb2 = Nothing
Set wb1 = Nothing
End Sub

The function below reads data from a closed Excel file and returns the result in an array. It loses formatting, formulas etc. You might want to call the isArrayEmpty function (at the bottom) in your main code to test that the function returned something.
Public Function getDataFromClosedExcelFile(parExcelFileName As String, parSheetName As String) As Variant
'see http://www.ozgrid.com/forum/showthread.php?t=19559
'returns an array (1 to nRows, 1 to nCols) which should be tested with isArrayEmpty in the calling function
Dim locConnection As New ADODB.Connection
Dim locRst As New ADODB.Recordset
Dim locConnectionString As String
Dim locQuery As String
Dim locCols As Variant
Dim locResult As Variant
Dim i As Long
Dim j As Long
On Error GoTo error_handler
locConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Data Source=" & parExcelFileName & ";" _
& "Extended Properties=""Excel 8.0;HDR=YES"";"
locQuery = "SELECT * FROM [" & parSheetName & "$]"
locConnection.Open ConnectionString:=locConnectionString
locRst.Open Source:=locQuery, ActiveConnection:=locConnection
If locRst.EOF Then 'Empty sheet or only one row
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''' FIX: an empty sheet returns "F1"
'''''' http://support.microsoft.com/kb/318373
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If locRst.Fields.Count = 1 And locRst.Fields(0).Name = "F1" Then Exit Function 'Empty sheet
ReDim locResult(1 To 1, 1 To locRst.Fields.Count) As Variant
For i = 1 To locRst.Fields.Count
locResult(1, i) = locRst.Fields(i - 1).Name
Next i
Else
locCols = locRst.GetRows
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''' FIX: an empty sheet returns "F1"
'''''' http://support.microsoft.com/kb/318373
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If locRst.Fields.Count = 1 And locRst.Fields(0).Name = "F1" And UBound(locCols, 2) = 0 And locCols(0, 0) = "" Then Exit Function 'Empty sheet
ReDim locResult(1 To UBound(locCols, 2) + 2, 1 To UBound(locCols, 1) + 1) As Variant
If locRst.Fields.Count <> UBound(locCols, 1) + 1 Then Exit Function 'Not supposed to happen
For j = 1 To UBound(locResult, 2)
locResult(1, j) = locRst.Fields(j - 1).Name
Next j
For i = 2 To UBound(locResult, 1)
For j = 1 To UBound(locResult, 2)
locResult(i, j) = locCols(j - 1, i - 2)
Next j
Next i
End If
locRst.Close
locConnection.Close
Set locRst = Nothing
Set locConnection = Nothing
getDataFromClosedExcelFile = locResult
Exit Function
error_handler:
'Wrong file name, sheet name, or other errors...
'Errors (#N/A, etc) on the sheet should be replaced by Null but should not raise an error
If locRst.State = ADODB.adStateOpen Then locRst.Close
If locConnection.State = ADODB.adStateOpen Then locConnection.Close
Set locRst = Nothing
Set locConnection = Nothing
End Function
Public Function isArrayEmpty(parArray As Variant) As Boolean
'Returns false if not an array or dynamic array that has not been initialised (ReDim) or has been erased (Erase)
If IsArray(parArray) = False Then isArrayEmpty = True
On Error Resume Next
If UBound(parArray) < LBound(parArray) Then isArrayEmpty = True: Exit Function Else: isArrayEmpty = False
End Function
Sample use:
Sub test()
Dim data As Variant
data = getDataFromClosedExcelFile("myFile.xls", "Sheet1")
If Not isArrayEmpty(data) Then
'Copies content on active sheet
ActiveSheet.Cells(1,1).Resize(UBound(data,1), UBound(data,2)) = data
End If
End Sub

Related

Excel VBA - Running a Macro against all files in a folder [duplicate]

I have a folder where I receive 1000+ excel files on daily bases they all are same format and structure. What I want to do is run a macro on all 100+ files on daily bases ?
Is there way to automate this ? So I can keep running that same macro on 1000+ files daily.
Assuming that you put your files in "Files" directory relative to your master workbook your code might look like this:
Sub ProcessFiles()
Dim Filename, Pathname As String
Dim wb As Workbook
Pathname = ActiveWorkbook.Path & "\Files\"
Filename = Dir(Pathname & "*.xls")
Do While Filename <> ""
Set wb = Workbooks.Open(Pathname & Filename)
DoWork wb
wb.Close SaveChanges:=True
Filename = Dir()
Loop
End Sub
Sub DoWork(wb As Workbook)
With wb
'Do your work here
.Worksheets(1).Range("A1").Value = "Hello World!"
End With
End Sub
In this example DoWork() is your macro that you apply to all of your files. Make sure that you do all your processing in your macro is always in the context of the wb (currently opened workbook).
Disclaimer: all possible error handling skipped for brevity.
A part of the question might be how do I run this on 1000 files?... Do I have to add this macro to all 1000 workbooks?
One way to do this is to add your macro's centrally to the file PERSONAL.XLSB (sometimes the extension might be different). This file will be loaded in the background every time you start Excel and makes your macro's available at any time.
Initially the PERSONAL.XLSB file will NOT be there. To automatically create this file, just start recording a "dummy" macro (with the record button on the left-bottom of a spreadsheet) and select "Personal Macro Workbook" to store it in.
After recording your macro, you can open the VBA editor with Alt+F11 and you will see the PERSONAL.XLSB file with the "dummy" recorded macro.
I use this file to store loads of general macro's which are always available, independent of which .xlsx file I have open. I have added these macro's to my own menu ribbon.
One disadvantage of this common macro file is that if you launch more than one instance of Excel, you will get an error message that the PERSONAL.XLSB file is already in use by Excel instance Nr. 1. This is no problem as long as you do not add new macro's at this moment.
Thank you very much for this
Sub ProcessFiles()
Dim Filename, Pathname As String
Dim wb As Workbook
Pathname = ActiveWorkbook.Path & "C:\Users\jkatanan\Desktop\20170206Glidepath\V37\"
Filename = Dir(Pathname & "*.xls")
Do While Filename <> ""
Set wb = Workbooks.Open(Pathname & Filename)
BSAQmacro wb
wb.Close SaveChanges:=True
Filename = Dir()
Loop
End Sub
Sub DoWork(wb As Workbook)
With wb
'Do your work here
.Worksheets(1).Range("A1").Value = "Hello World!"
End With
End Sub
Sub ProcessFiles()
Dim Filename, Pathname As String
Dim wb As Workbook
Pathname = ActiveWorkbook.Path & "\C:\Users\20098323\Desktop\EXCL\"
Filename = Dir(Pathname & "*.xlsx")
Do While Filename <> ""
Set wb = Workbooks.Open(Pathname & Filename)
DoWork wb
wb.Close SaveChanges:=True
Filename = Dir()
Loop
End Sub
Sub DoWork(wb As Workbook)
With wb
'Do your work here
.Worksheets(1).Range("A1").Value = "Hello World!"
End With
End Sub
While running this code its showing bad file name or number.
i have stored my all file in ("\C:\Users\20098323\Desktop\EXCL\") EXCL folder
Instead of passing the values to DoWork one can also run the jobs in Processfiles().
Sub ProcessFiles()
Dim Filename, Pathname As String
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim Sheet As Worksheet
Dim PasteStart As Range
Dim Counter As Integer
Set wb1 = ActiveWorkbook
Set PasteStart = [RRimport!A1]
Pathname = ActiveWorkbook.Path & "\For Macro to run\"
Filename = Dir(Pathname & "*.xls")
Do While Filename <> ""
Set wb2 = Workbooks.Open(Pathname & Filename)
For Each Sheet In wb2.Sheets
With Sheet.UsedRange
.Copy PasteStart
Set PasteStart = PasteStart.Offset(.Rows.Count)
End With
Next Sheet
wb2.Close
Filename = Dir()
Loop
End Sub
This isn't an exact answer to the question, since I was just trying to run a single script on any file that I opened and couldn't get that to work, but I thought this might help others like me. It worked once I moved the code into a Module in the Visual Basic for Applications dialog box (go to "Insert" then "Module"). Once I added my VBA code to a module, I was able to open any other file in Excel (even a CSV file) and go to Macros, and run the Macro from the other file (that contains the Module with the code) on the file that I had open.
Thanks Peterm!!
Actually, I did my macro using exactly the same code you posted (process_fiels and dowork).
It worked brilliant!! (before my question)
Each of my 1000 workbooks has 84 worksheets. My own macro (which finally works!) splits each workbook into 85 different files (the original + a short version of each worksheet saved as an individual file).
That leaves me with 1000 files + 1000x85 in the same folder, and that would be really hard to sort out.
What I really need is for Process_Files to take the first file, create a folder with the name of the first file, move the first file to the folder with ist name, then run my macro (in the folder named after the first file in the newly created folder...), go back and take the second file, create a folder with the name of the second file, move the second file to the folder with ist name, then run my macro (in the folder named after the second file in the newly created folder...), etc...
At the end, I should have moved all files into folders with the same name as the files, and the contents of the original \Files\ folder would be 1000 folders with the name of the original files, containgin the original files + 84 files which my own macro already does.
Maybe it is easier with the code:
Sub ProcessFiles()
Dim Filename, Pathname As String
Dim wb As Workbook
Pathname = ActiveWorkbook.Path & "\Files\"
Filename = Dir(Pathname & "*.xls")
Do While Filename <> ""
(Here, it should read the file name, create a folder with the file name, move the file into this newly created folder)
Set wb = Workbooks.Open(Pathname & Filename) <- open file, just as is.
DoWork wb <- do my macro,just as is
wb.Close SaveChanges:=False <- not save, to keep the original file
(go back to the original \Files\ folder)
Filename = Dir() <- Next file, just as is
Loop
End Sub
Sub DoWork(wb As Workbook)
With wb
MyMacro
End With
End Sub
Many thanks, this site is great!
__________________edit, the macro now works _________________________
As you can see, I am no VBA expert, but the macro finally works. The code is not neat at all, I am no SW programmer.
Here it is, it might help some one some day.
Sub ProcessFiles_All()
Dim Filename, Pathname, NewPath, FileSource, FileDestination As String
Dim wb As Workbook
Pathname = ActiveWorkbook.Path & "\Files\"
Filename = Dir(Pathname & "*.csv")
Do While Filename <> ""
NewPath = Pathname & Left(Filename, 34) & "\"
On Error Resume Next
MkDir (NewPath)
On Error GoTo 0
Set wb = Workbooks.Open(Pathname & Filename)
DoWorkPlease wb ' <------------ It is important to say please!!
On Error Resume Next
wb.Close SaveChanges:=False
if Err.Number <> 0 then
‘Error handler needed here
End if
Filename = Dir()
Loop
End Sub
Sub DoWorkPlease(wb As Workbook)
With wb
‘ Since my application has over 1800 cells for each column and it is time consuming
‘ I use a “testing mode” were I only play with 18 values.
Dim TestingMode As Integer
Dim ThisRange(1 To 4) As Variant
TestingMode = 0
If TestingMode = 1 Then
ThisRange(1) = "B2:CG18"
ThisRange(2) = "CT2:CT18"
ThisRange(3) = "CH2:CN18"
ThisRange(4) = "CN2:CS18"
Rows("19:18201").Select
Selection.Delete Shift:=xlUp
End If
If TestingMode = 0 Then
ThisRange(1) = "B2:CG18201"
ThisRange(2) = "CT2:CT18201"
ThisRange(3) = "CH2:CN18201"
ThisRange(4) = "CN2:CS18201"
End If
‘ speed up the macro, turn off updating and alerts
Application.ScreenUpdating = False
Application.DisplayAlerts = False
‘ Here is my code that manipulates the cell values from digits (values read by sensors need to be “translated” into real world values. Code not here actually.
‘Then I copy the whole thing into just numbers, there are no longer formulas, easier to work this way.
'_____________________________________
'Get just values - no more formulas
Sheets.Add After:=Sheets(Sheets.Count)
Sheets("Sheet1").Select
Columns("A:CT").Select
Selection.Copy
Sheets("Sheet2").Select
Columns("A:A").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.NumberFormat = "0"
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
‘ Then I save this new workbook into a folder with its own name (and under the folder \FILES\
'_____________________________________
'Save the work under its own folder
Dim CleanName, CleanPath, CleanNewName As Variant
CleanPath = ActiveWorkbook.Path
CleanName = ActiveWorkbook.Name
CleanName = Left(CleanName, 34) ‘I take out the extension
CleanPath = CleanPath + "\" + CleanName
CleanNewName = CleanPath + "\" + CleanName
CleanNewName = CleanNewName + "_clean.csv" ‘ and I add “clean” to have a different name now.
On Error Resume Next
ActiveWorkbook.SaveAs Filename:=CleanNewName, FileFormat:=xlCSV, CreateBackup:=False
‘If there is an error I create an empty folder with the name of the file to know which file needs rework.
If Err.Number <> 0 Then
MkDir (CleanPath + "_error_" + CleanName)
End If
'Resume Next
ActiveSheet.Move _
After:=ActiveWorkbook.Sheets(1)
‘ Then I split the workbook into individual files with the data I need for individual sensors.
‘ Here are the individual ranges I need for each file. Since I have over 1000 files, it is worth the effort.
'_______________ the Split!!______________________________
Dim Col(1 To 98) As Variant
Col(1) = "A:A,B:B,CH:CH,CN:CN,CT:CT"
Col(2) = "A:A,C:C,CH:CH,CN:CN,CT:CT"
Col(3) = "A:A,D:D,CH:CH,CN:CN,CT:CT"
Col(4) = "A:A,E:E,CH:CH,CN:CN,CT:CT"
Col(5) = "A:A,F:F,CH:CH,CN:CN,CT:CT"
Col(6) = "A:A,G:G,CH:CH,CN:CN,CT:CT"
Col(7) = "A:A,H:H,CH:CH,CN:CN,CT:CT"
Col(8) = "A:A,I:I,CH:CH,CN:CN,CT:CT"
Col(9) = "A:A,J:J,CH:CH,CN:CN,CT:CT"
Col(10) = "A:A,K:K,CH:CH,CN:CN,CT:CT"
Col(11) = "A:A,L:L,CH:CH,CN:CN,CT:CT"
Col(12) = "A:A,M:M,CH:CH,CN:CN,CT:CT"
Col(13) = "A:A,N:N,CH:CH,CN:CN,CT:CT"
Col(14) = "A:A,O:O,CH:CH,CN:CN,CT:CT"
Col(15) = "A:A,P:P,CI:CI,CO:CO,CT:CT"
Col(16) = "A:A,Q:Q,CI:CI,CO:CO,CT:CT"
Col(17) = "A:A,R:R,CI:CI,CO:CO,CT:CT"
Col(18) = "A:A,S:S,CI:CI,CO:CO,CT:CT"
Col(19) = "A:A,T:T,CI:CI,CO:CO,CT:CT"
Col(20) = "A:A,U:U,CI:CI,CO:CO,CT:CT"
Col(21) = "A:A,V:V,CI:CI,CO:CO,CT:CT"
Col(22) = "A:A,W:W,CI:CI,CO:CO,CT:CT"
Col(23) = "A:A,X:X,CI:CI,CO:CO,CT:CT"
Col(24) = "A:A,Y:Y,CI:CI,CO:CO,CT:CT"
Col(25) = "A:A,Z:Z,CI:CI,CO:CO,CT:CT"
Col(26) = "A:A,AA:AA,CI:CI,CO:CO,CT:CT"
Col(27) = "A:A,AB:AB,CI:CI,CO:CO,CT:CT"
Col(28) = "A:A,AC:AC,CI:CI,CO:CO,CT:CT"
Col(29) = "A:A,AD:AD,CJ:CJ,CP:CP,CT:CT"
Col(30) = "A:A,AE:AE,CJ:CJ,CP:CP,CT:CT"
Col(31) = "A:A,AF:AF,CJ:CJ,CP:CP,CT:CT"
Col(32) = "A:A,AG:AG,CJ:CJ,CP:CP,CT:CT"
Col(33) = "A:A,AH:AH,CJ:CJ,CP:CP,CT:CT"
Col(34) = "A:A,AI:AI,CJ:CJ,CP:CP,CT:CT"
Col(35) = "A:A,AJ:AJ,CJ:CJ,CP:CP,CT:CT"
Col(36) = "A:A,AK:AK,CJ:CJ,CP:CP,CT:CT"
Col(37) = "A:A,AL:AL,CJ:CJ,CP:CP,CT:CT"
Col(38) = "A:A,AM:AM,CJ:CJ,CP:CP,CT:CT"
Col(39) = "A:A,AN:AN,CJ:CJ,CP:CP,CT:CT"
Col(40) = "A:A,AO:AO,CJ:CJ,CP:CP,CT:CT"
Col(41) = "A:A,AP:AP,CJ:CJ,CP:CP,CT:CT"
Col(42) = "A:A,AQ:AQ,CJ:CJ,CP:CP,CT:CT"
Col(43) = "A:A,AR:AR,CK:CK,CQ:CQ,CT:CT"
Col(44) = "A:A,AS:AS,CK:CK,CQ:CQ,CT:CT"
Col(45) = "A:A,AT:AT,CK:CK,CQ:CQ,CT:CT"
Col(46) = "A:A,AU:AU,CK:CK,CQ:CQ,CT:CT"
Col(47) = "A:A,AV:AV,CK:CK,CQ:CQ,CT:CT"
Col(48) = "A:A,AW:AW,CK:CK,CQ:CQ,CT:CT"
Col(49) = "A:A,AX:AX,CK:CK,CQ:CQ,CT:CT"
Col(50) = "A:A,AY:AY,CK:CK,CQ:CQ,CT:CT"
Col(51) = "A:A,AZ:AZ,CK:CK,CQ:CQ,CT:CT"
Col(52) = "A:A,BA:BA,CK:CK,CQ:CQ,CT:CT"
Col(53) = "A:A,BB:BB,CK:CK,CQ:CQ,CT:CT"
Col(54) = "A:A,BC:BC,CK:CK,CQ:CQ,CT:CT"
Col(55) = "A:A,BD:BD,CK:CK,CQ:CQ,CT:CT"
Col(56) = "A:A,BE:BE,CK:CK,CQ:CQ,CT:CT"
Col(57) = "A:A,BF:BF,CL:CL,CR:CR,CT:CT"
Col(58) = "A:A,BG:BG,CL:CL,CR:CR,CT:CT"
Col(59) = "A:A,BH:BH,CL:CL,CR:CR,CT:CT"
Col(60) = "A:A,BI:BI,CL:CL,CR:CR,CT:CT"
Col(61) = "A:A,BJ:BJ,CL:CL,CR:CR,CT:CT"
Col(62) = "A:A,BK:BK,CL:CL,CR:CR,CT:CT"
Col(63) = "A:A,BL:BL,CL:CL,CR:CR,CT:CT"
Col(64) = "A:A,BM:BM,CL:CL,CR:CR,CT:CT"
Col(65) = "A:A,BN:BN,CL:CL,CR:CR,CT:CT"
Col(66) = "A:A,BO:BO,CL:CL,CR:CR,CT:CT"
Col(67) = "A:A,BP:BP,CL:CL,CR:CR,CT:CT"
Col(68) = "A:A,BQ:BQ,CL:CL,CR:CR,CT:CT"
Col(69) = "A:A,BR:BR,CL:CL,CR:CR,CT:CT"
Col(70) = "A:A,BS:BS,CL:CL,CR:CR,CT:CT"
Col(71) = "A:A,BT:BT,CM:CM,CS:CS,CT:CT"
Col(72) = "A:A,BU:BU,CM:CM,CS:CS,CT:CT"
Col(73) = "A:A,BV:BV,CM:CM,CS:CS,CT:CT"
Col(74) = "A:A,BW:BW,CM:CM,CS:CS,CT:CT"
Col(75) = "A:A,BX:BX,CM:CM,CS:CS,CT:CT"
Col(76) = "A:A,BY:BY,CM:CM,CS:CS,CT:CT"
Col(77) = "A:A,BZ:BZ,CM:CM,CS:CS,CT:CT"
Col(78) = "A:A,CA:CA,CM:CM,CS:CS,CT:CT"
Col(79) = "A:A,CB:CB,CM:CM,CS:CS,CT:CT"
Col(80) = "A:A,CC:CC,CM:CM,CS:CS,CT:CT"
Col(81) = "A:A,CD:CD,CM:CM,CS:CS,CT:CT"
Col(82) = "A:A,CE:CE,CM:CM,CS:CS,CT:CT"
Col(83) = "A:A,CF:CF,CM:CM,CS:CS,CT:CT"
Col(84) = "A:A,CG:CG,CM:CM,CS:CS,CT:CT"
‘ I want to split 84 new files, so for testing I use only 1, and for the real thing I go with 84
Dim CounterMode As Integer
If TestingMode = 1 Then CounterMode = 1 Else CounterMode = 84
For i = 1 To CounterMode
‘ this code takes the columns need, and paste it into a new workbook.
Sheets("Sheet1").Select
Cells.Select
Selection.ClearContents
Range("A1").Activate
Sheets(2).Select
Range(Col(i)).Select
Selection.Copy
Sheets("Sheet1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("A:E").EntireColumn.AutoFit
‘ Save the individual file
'_____________save the work________________
Dim ThePath, TheName, TheSwitch As String
ThePath = ActiveWorkbook.Path + “\”
TheName = Left(ActiveWorkbook.Name, 34) ‘ take out the extension from the name
ThePath = ThePath + TheName
TheSwitch = Cells(3, 2) ‘ In Cell (3,2) I have the name of the individual name, so I added to the file name.
TheName = ThePath + "_" + TheSwitch + ".xls"
Range("A1").Select
Sheets("Sheet1").Select
Sheets("Sheet1").Copy
Dim SheetName As Variant
‘ I name Sheets(1) as Sheet1, since the original sheet has the name and date of the test.
‘ I do this to have the same name on all file in order to do a plot, then I rename the sheet with the
‘ original name
SheetName = ActiveSheet.Name
ActiveWorkbook.Sheets(1).Name = "Sheet1"
‘ here is the plot
Columns("A:E").EntireColumn.AutoFit
Columns("B:E").Select
ActiveSheet.Shapes.AddChart.Select
ActiveChart.SetSourceData Source:=Range("'Sheet1'!$B:$E")
ActiveChart.ChartType = xlXYScatterLinesNoMarkers
ActiveWorkbook.Sheets(1).Name = SheetName
‘save
On Error Resume Next
ActiveWorkbook.SaveAs Filename:=TheName, FileFormat:=56, CreateBackup:=False
If Err.Number <> 0 Then
MkDir (ThePath + "_error_" + TheName)
End If
ActiveWorkbook.Close
Next i
'____________________That was the Split__________________________________
' Turn on screenupdating:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Range("A1").Select
End With
End Sub

VBA to Add 22 pipes(|) to Text file using Macro

I hope you can help I have a piece of code and what it does is it takes information from two excel sheets and puts it into two text docs for consumption in a database.
The code I have works fine but 22 columns have been added in the database where the text file is destined to be consumed so I need to put 22 pipes(|) before company Id in Notepad file
The first pic is of the Excel sheet where staff can input data
The second pic shows the excel sheet where the data is sorted from the 'Meeting Close Out Template' and the macro picks up the data for transformation to text. This sorting sheet is called 'Template-EFPIA-iTOV' the columns in grey are what the macro pics up
In the below pic you can see that Company Id is the last column in 'Template-EFPIA-iTOV
Below is how the sheet 'Template-EFPIA-iTOV ' is represented in text
Here is the Company IDs in the Text file
Because the destination database has now got an extra 22 columns before Company Id I need my macro to put 22 pipes(|) before Company id in the text doc.
The Excel sheet 'Template EFPIA Customer' is also converetd to text but this is fine and needs no amendments.
My Code is below. As always any help is greatly appreciated.
Pic of Macro front end
CODE
'Variables for Deduplication
Dim WB_Cust As Workbook
'File Variables
Dim DTOV_Directory As String
Dim DTOV_File As String
Dim ITOV_Directory As String
Dim ITOV_file As String
Const DELIMITER As String = "|"
' Variables for writing text into file
Dim WriteObject As Object
Dim OUTFilename As String
Dim MyWkBook As Workbook
Dim MyWkSheet As Worksheet
Dim OutputFile As String ' Output flat file name
Dim SysCode As String ' Variable for text string of system code to be filled into information system code column
Dim strFilenameOut As String ' Variable for name of file being processed. It is used for SysCode and OutputFile determination.
Dim CustAddressSave As Range
'Processing of one file. This procedure is called when only one of file types are selected
Public Sub Process_template(Directory As String, File As String, FileFlag As String)
Application.ScreenUpdating = False 'Turns off switching of windows
If FileFlag = "D" Then 'Variables setup for DTOV
DTOV_Directory = Directory
DTOV_File = File
ElseIf FileFlag = "I" Then 'Variables setup for ITOV
ITOV_Directory = Directory
ITOV_file = File
Else
MsgBox "Unhandled Exception - Unknown files sent"
Exit Sub
End If
Call Process(1, FileFlag)
Application.ScreenUpdating = True 'Turns On switching of windows
End Sub
'Processing of two file. This procedure is called when both file types are to be processed
Public Sub Process_Templates(DTOV_Dir As String, DTOV_Fil As String, ITOV_Dir As String, ITOV_Fil As String)
Application.ScreenUpdating = False 'Turns off switching of windows
DTOV_Directory = DTOV_Dir
DTOV_File = DTOV_Fil
ITOV_Directory = ITOV_Dir
ITOV_file = ITOV_Fil
Call Process(2, "B")
Application.ScreenUpdating = True 'Turns on switching of windows
End Sub
' *****************************************************************************
' Management of File to write in UT8 format
' *****************************************************************************
' This function open the file indicated to be able to write inside
Private Sub OUTFILE_OPEN(filename As String)
Set WriteObject = CreateObject("ADODB.Stream")
WriteObject.Type = 2 'Specify stream type - we want To save text/string data.
WriteObject.Charset = "utf-8" 'Specify charset For the source text data.
WriteObject.Open 'Open the stream And write binary data To the object
OUTFilename = filename
End Sub
' This function closes the file
Private Sub OUTFILE_CLOSE()
WriteObject.SaveToFile OUTFilename, 2
WriteObject.Close ' Close the file
End Sub
' Write a string in the outfile
Private Sub OUTFILE_WRITELINE(txt As String)
WriteObject.WriteText txt & Chr(13) & Chr(10)
txt = ""
End Sub
' subprocedure to read TOV data into stream and call procedure to generate file
Public Sub generate_tov(i_Sheet_To_Process As String, _
i_OffsetShift As Integer)
Dim sOut As String ' text to be written into file
'Set OutputFile = "sarin"
Sheets(i_Sheet_To_Process).Select
Range("C2").Select
'Parsing of system code from filename
strFilenameOut = ActiveWorkbook.Name 'example - initial file name: EFPIA_DTOV-BE-MTOV-201503271324.xlsx
SysCode = Left(strFilenameOut, InStrRev(strFilenameOut, "-") - 1) 'example - after LEFT cut EFPIA_ITOV-BE-MTOV
SysCode = Right(SysCode, Len(SysCode) - InStrRev(SysCode, "-")) 'example - after RIGHT cut MTOV
Do Until (IsError(ActiveCell.Offset(0, 1).Value) = True)
If ActiveCell.Offset(0, 1).Value = "" Then
'end-of-file reached, hence exist the do loop
Exit Do
End If
ActiveCell.Value = SysCode
ActiveCell.Offset(0, i_OffsetShift).Value = Application.WorksheetFunction.VLookup(Sheets("Template - EFPIA Customer").Cells(ActiveCell.Row, 3).Value, Sheets("Appendix").Range("N1:O103"), 2, "FALSE") & "_" & ActiveCell.Offset(0, i_OffsetShift).Value
ActiveCell.Offset(1, 0).Select
Loop
OutputFile = Left(strFilenameOut, InStrRev(strFilenameOut, ".") - 1) & ".txt"
If (IsError(ActiveCell.Offset(0, 1).Value) = True) Then
MsgBox ("incorrect data in the TOV source file. Please correct and re-run the macro")
Exit Sub
Else
Call generate_file
End If
End Sub
' procedures to write stream data into file for both TOV and customer
Public Sub generate_file()
Dim X As Integer
Dim Y As Long
Dim FieldValue As String
Dim NBCol As Integer
Dim sOut As String ' text to be written into file
OUTFILE_OPEN (OutputFile) 'Open (setup) the output file
'Open OutputFile For Output As #1 'Prepares new file for output
Set MyWkBook = ActiveWorkbook
Set MyWkSheet = ActiveSheet
NBCol = 0
Do While (Trim(MyWkSheet.Cells(1, NBCol + 1)) <> "")
NBCol = NBCol + 1
Loop
' Scroll all rows
Y = 1
Do While (Trim(MyWkSheet.Cells(Y, 4)) <> "")
sOut = ""
For X = 1 To NBCol
' here, if required, insert a convertion type function
FieldValue = Trim(MyWkSheet.Cells(Y, X))
FieldValue = Replace(FieldValue, "|", "/") 'Replaces pipes from input file to slashes to avoid mismatches during ETL
If FieldValue = "0" Then FieldValue = "" 'Replaces "only zeroes" - might need redoing only for amount columns
If InStr(MyWkSheet.Cells(1, X), "Amount") > 0 Then FieldValue = Replace(FieldValue, ",", ".")
' add into the string
If X = NBCol Then
sOut = sOut & FieldValue
Else
sOut = sOut & FieldValue & DELIMITER
End If
Next X
Y = Y + 1
OUTFILE_WRITELINE sOut
Loop
OUTFILE_CLOSE
End Sub
' read the customer data into stream
Public Sub read_customer(i_Sheet_To_Process As String, _
i_range As String)
Dim CCST As Workbook ' Variable to keep reference for template Workbook that is being used for copy-paste of Customer data into virtuall Workbook
Sheets(i_Sheet_To_Process).Select
ActiveSheet.UsedRange.Copy
Set CCST = ActiveWorkbook
WB_Cust.Activate
If i_range = "" Then
Sheets("Sheet1").Range(CustAddressSave.Address).PasteSpecial xlPasteValues
Range(CustAddressSave.Address).Select
ActiveCell.Offset(0, 2).Select
Rows(CustAddressSave.Row).EntireRow.Delete
Else
Sheets("Sheet1").Range("A1").PasteSpecial xlPasteValues
Range("C2").Select
End If
'Call LookingUp(CCST)
Do Until (IsError(ActiveCell.Offset(0, 1).Value) = True)
If ActiveCell.Offset(0, 1).Value = "" Then
'end-of-file reached, hence exist the do loop
Exit Do
End If
ActiveCell.Offset(0, 1).Value = Application.WorksheetFunction.VLookup(ActiveCell.Offset(0, 0).Value, CCST.Sheets("Appendix").Range("N1:O103"), 2, "FALSE") & "_" & ActiveCell.Offset(0, 1).Value
ActiveCell.Value = SysCode
ActiveCell.Offset(1, 0).Select
Loop
If (IsError(ActiveCell.Offset(0, 1).Value) = True) Then
MsgBox ("incorrect data in the source file. Please correct and re-run the macro")
Exit Sub
Else
Set CustAddressSave = ActiveCell.Offset(0, -2) 'Saves position where 2nd Cust data sheet will be copied
OutputFile = Left(Mid(strFilenameOut, 1, (InStr(strFilenameOut, "_"))) & "CUST" & Mid(strFilenameOut, (InStr(strFilenameOut, "-"))), InStrRev(strFilenameOut, ".") - 1) & ".txt"
End If
End Sub
'Main Procedure of the module that processes the files
Private Sub Process(Loops As Integer, FileFlag As String) 'Loops - number of files (1 or 2), FileFlag - which file is to be processed (I - ITOV, D - DTOV, B - Both)
Set WB_Cust = Workbooks.Add
' This virtual workbook is created only for duration of the processing. It is used to copy paste CUSTOMER data form one or both templates.
If FileFlag = "D" Or FileFlag = "B" Then
' process DTOV first always
Call Open_DTOV
'----------------------------------------------------------
Call generate_tov("Template - Transfer of Value", 3)
' if the file have data issues, then abort the procedure.
If (IsError(ActiveCell.Offset(0, 1).Value) = True) Then
GoTo HandleException
End If
'----------------------------------------------------------
Call read_customer("Template - EFPIA Customer", "A")
' if the file have data issues, then abort the procedure.
If (IsError(ActiveCell.Offset(0, 1).Value) = True) Then
GoTo HandleException
End If
End If
If FileFlag = "I" Or FileFlag = "B" Then
Call Open_ITOV
'----------------------------------------------------------
Call generate_tov("Template - EFPIA iToV", 17)
' if the file have data issues, then abort the procedure.
If (IsError(ActiveCell.Offset(0, 1).Value) = True) Then
GoTo HandleException
End If
'----------------------------------------------------------
If FileFlag = "B" Then
Call read_customer("Template - EFPIA Customer", "")
Else
Call read_customer("Template - EFPIA Customer", "A")
End If
' if the file have data issues, then abort the procedure.
If (IsError(ActiveCell.Offset(0, 1).Value) = True) Then
GoTo HandleException
End If
End If
Call Deduplicate
Call generate_file ' generate single customer file
MsgBox "Export Process is completed"
HandleException:
' Closes the virtual workbook used for consolidation and deduplication of customers
WB_Cust.Saved = True
WB_Cust.Close
ActiveWorkbook.Saved = True 'Closes Template
ActiveWorkbook.Close (False)
If Loops = 2 Then 'Closes second Template if two files are being processed
ActiveWorkbook.Saved = True
ActiveWorkbook.Close (False)
End If
Application.ScreenUpdating = True 'Turns back on switching to exported excel file once it gets opened
Exit Sub
End Sub
'Unused Procedure to reduce Customer data processing code. Does not work now.
Private Sub LookingUp(CCST As Workbook)
Do Until (ActiveCell.Offset(0, 1).Value = "")
ActiveCell.Offset(0, 1).Value = Application.WorksheetFunction.VLookup(ActiveCell.Offset(0, 0).Value, CCST.Sheets("Appendix").Range("N1:O103"), 2, "FALSE") & "_" & ActiveCell.Offset(0, 1).Value
ActiveCell.Value = SysCode
ActiveCell.Offset(1, 0).Select
Loop
End Sub
'Open DTOV Template
Private Sub Open_DTOV()
Workbooks.Open (DTOV_Directory + DTOV_File)
End Sub
'Open ITOV Template
Private Sub Open_ITOV()
Workbooks.Open (ITOV_Directory + ITOV_file)
End Sub
'Deduplicating Customer data based on Source_Party_Identifier, which already contains source code prefix
Private Sub Deduplicate()
ActiveSheet.UsedRange.RemoveDuplicates Columns:=4, Header:=xlYeas
End Sub
Since your code is set up to detect the number of columns using this section of generate_file:
Do While (Trim(MyWkSheet.Cells(1, NBCol + 1)) <> "")
NBCol = NBCol + 1
Loop
...and then dynamically saves all the rows to the pipe delimited text file, I strongly recommend just adding the new columns into your sheet, even if they are going to be blank.
However, if you want to jury-rig it to get the job done, you can always add 22 pipes to each output row. Replace OUTFILE_WRITELINE sOut in the generate_file loop with OUTFILE_WRITELINE "||||||||||||||||||||||" & sOut.
Make sure, if you do decide to use that ugly hack, that you comment it very carefully so that you and any other maintainers of the code can find and fix it when the requirements inevitably change again.

Read closed .xlsm files as xml files to pull data

I am a new programmer and I am trying to find a way to extract one range of data from multiple workbooks and copy them into a master file. I have already wrote the code to do this below, but the problem that I am having is that my code physically opens the xlsm files > copies the data > then goes back into the master file to paste. Since this is being done to thousands of files at once, it takes hours to complete. My boss told me there is a way to copy the data from the xlsm files without having the code actually open the file if it is read as xml or as a .txt file. I have searched online for this, but cannot find anything on how this would be done. Any help would be greatly appreciated.
The code I have that physically opens the workbooks:
Option Explicit
Sub ReadDataFromCloseFile()
On Error GoTo ErrHandler
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim FileType As String
Dim FilePath As String
FileType = "*.xlsm*" 'The file type to search for
FilePath = "C:\Users\hasib\xlsm's\" 'The folder to search
Dim src As Workbook
Dim OutputCol As Variant
Dim Curr_File As Variant
OutputCol = 9 'The first row of the active sheet to start writing to
Curr_File = Dir(FilePath & FileType)
Do Until Curr_File = ""
' OPEN THE SOURCE EXCEL WORKBOOK IN "READ ONLY MODE".
Set src = Workbooks.Open(FilePath & Curr_File, True, True)
Sheets("Reporting").Range("I7:I750").Copy
Workbooks("Master.xlsm").Activate
Sheets("Sheet2").Select
Sheets("Sheet2").Cells(4, OutputCol).Select
ActiveCell.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
OutputCol = OutputCol + 1
' CLOSE THE SOURCE FILE.
src.Close False ' FALSE - DON'T SAVE THE SOURCE FILE.
Curr_File = Dir
Loop
Set src = Nothing
Application.EnableEvents = True
Application.ScreenUpdating = True
ErrHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
I found out that there is a formula you can use in a cell that will pull in data from a closed workbook. If you type ='folderpath[filename]Sheetname'Cell into a cell it will automatically pull in that information. Using this logic I created the below to loop through all my files and paste data into my workbook from the files being called:
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.InitialFileName = "c:\"
fd.InitialView = msoFileDialogViewList
fd.AllowMultiSelect = True
FileChosen = fd.Show
FilePath = fd.SelectedItems(1)
FolderPath = Left(FilePath, InStrRev(FilePath, "\"))
If FileChosen = -1 Then
'open each of the files chosen
For c = 1 To fd.SelectedItems.count
FileName = Dir(fd.SelectedItems(c))
ThisWorkbook.Sheets("Batch Results").Cells(OutputRow, OutputCol).Formula = "='" & FolderPath & "[" & FileName & "]Reporting'!$I7"
OutputCol = OutputCol + 1
Next c
End If
ThisWorkbook.Sheets("Batch Results").Select
Cells(1, OutputCol).Select
EndColumn = Split(ActiveCell(1).Address(1, 0), "$")(0)
RangeName = ("A1:" & EndColumn & "1")
Range(RangeName).Select
Selection.AutoFill Destination:=Range("A1:" & EndColumn & "558"), Type:=xlFillDefualt

How to loop through worksheets in a defined order using VBA

I have the below working code which loops through each worksheet and if the value defined in the range (myrange) is 'Y', it outputs those sheets into a single PDF document. My challange is that i want to define the order that they are output in the PDF based on the number value in the range (for example 1,2,3,4,5,6,7 etc) instead of 'Y'. I plan on using the same column in the myrange to check whether it needs to be output to PDF, by simply swapping the 'Y' for a number, such as '1' and '2'.
Currently the order is defined based on the location of the worksheet tabs. from left to right.
Any help will be much appreciated.
Sub Run_Me_To_Create_Save_PDF()
Dim saveAsName As String
Dim WhereTo As String
Dim sFileName As String
Dim ws As Worksheet
Dim printOrder As Variant '**added**
Dim myrange
On Error GoTo Errhandler
Sheets("Settings").Activate
' Retrieve value of 'Period Header' from Settings sheet
Range("C4").Activate
periodName = ActiveCell.Value
' Retrieve value of 'File Name' from Settings sheet
Range("C5").Activate
saveAsName = ActiveCell.Value
' Retrieve value of 'Publish PDF to Folder' from Settings sheet
Range("C6").Activate
WhereTo = ActiveCell.Value
Set myrange = Worksheets("Settings").Range("range_sheetProperties")
' Check if Stamp-field has any value at all and if not, add the current date.
If Stamp = "" Then Stamp = Date
' Assemble the filename
sFileName = WhereTo & saveAsName & " (" & Format(CDate(Date), "DD-MMM-YYYY") & ").pdf"
' Check whether worksheet should be output in PDF, if not hide the sheet
For Each ws In ActiveWorkbook.Worksheets
Sheets(ws.Name).Visible = True
printOrder = Application.VLookup(ws.Name, myrange, 4, False)
If Not IsError(printOrder) Then
If printOrder = "Y" Then
Sheets(ws.Name).Visible = True
End If
Else: Sheets(ws.Name).Visible = False
End If
Next
'Save the File as PDF
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
sFileName, Quality _
:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=True
' Unhide and open the Settings sheet before exiting
Sheets("Settings").Visible = True
Sheets("Settings").Activate
MsgBox "PDF document has been created and saved to : " & sFileName
Exit Sub
Errhandler:
' If an error occurs, unhide and open the Settings sheet then display an error message
Sheets("Settings").Visible = True
Sheets("Settings").Activate
MsgBox "An error has occurred. Please check that the PDF is not already open."
End Sub
---------------------- UPDATE: -------------------------------------
Thank you for all your input so far. I did get it to work briefly, but with more playing i've become stuck. I am now receiving a 'Subscript our of range' error with the below code at :
If sheetNameArray(x) <> Empty Then
Any ideas?
Sub Run_Me_To_Create_Save_PDF()
Dim saveAsName As String
Dim WhereTo As String
Dim sFileName As String
Dim ws As Worksheet
Dim myrange
ReDim sheetNameArray(0 To 5) As String
Dim NextWs As Worksheet
Dim PreviousWs As Worksheet
Dim x As Integer
'On Error GoTo Errhandler
Sheets("Settings").Activate
' Retrieve value of 'Period Header' from Settings sheet
Range("C4").Activate
periodName = ActiveCell.Value
' Retrieve value of 'File Name' from Settings sheet
Range("C5").Activate
saveAsName = ActiveCell.Value
' Retrieve value of 'Publish PDF to Folder' from Settings sheet
Range("C6").Activate
WhereTo = ActiveCell.Value
' Check if Stamp-field has any value at all and if not, add the current date.
If Stamp = "" Then Stamp = Date
' Assemble the filename
sFileName = WhereTo & saveAsName & " (" & Format(CDate(Date), "DD-MMM-YYYY") & ").pdf"
Set myrange = Worksheets("Settings").Range("range_sheetProperties")
For Each ws In ActiveWorkbook.Worksheets
printOrder = Application.VLookup(ws.Name, myrange, 4, False)
If Not IsError(printOrder) Then
printOrderNum = printOrder
If printOrderNum <> Empty Then
'Add sheet to array
num = printOrderNum - 1
sheetNameArray(num) = ws.Name
End If
End If
Next
MsgBox Join(sheetNameArray, ",")
'Order Tab sheets based on array
x = 1
Do While Count < 6
If sheetNameArray(x) <> Empty Then
Set PreviousWs = Sheets(sheetNameArray(x - 1))
Set NextWs = Sheets(sheetNameArray(x))
NextWs.Move after:=PreviousWs
x = x + 1
Else
Count = Count + 1
x = x + 1
End If
Loop
Sheets(sheetNameArray).Select
'Save the File as PDF
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sFileName, Quality _
:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=True
' open the Settings sheet before exiting
Sheets("Settings").Activate
MsgBox "PDF document has been created and saved to : " & sFileName
Exit Sub
Errhandler:
' If an error occurs, unhide and open the Settings sheet then display an error message
Sheets("Settings").Visible = True
Sheets("Settings").Activate
MsgBox "An error has occurred. Please check that the PDF is not already open."
End Sub
You would want to define the worksheets in an array.
This example uses a static array, knowing the sheets order and what you want to print in advance. This does work.
ThisWorkbook.Sheets(Array("Sheet1","Sheet2","Sheet6","Master","Sales")).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, fileName:=sFileName, Quality _
:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=True
The problem is that if a sheet is hidden, it will fail on the selection.
So you will need to already know which sheets pass the test to be printed or not before declaring the Array. Therefore you will need a dynamic array to build the list of Worksheets.
I did change how your PrintOrder works, instead of making the sheet invisible, it simply doesn't add it to the array, or vice versa, adds the ones you want to the array. Then you select the array at the end, and run your print macro that works.
I tested this using my own test values, and am trusting that your PrintOrder Test works. But this does work. I used it to print time sheets that only have more than 4 hours per day, and it succeeded, merging 5 sheets out of a workbook with 11 sheets into one PDF.. All of them qualified the test.
TESTED: Insert this instead of your For Each ws and add the Variable Declarations with yours
Sub DynamicSheetArray()
Dim wsArray() As String
Dim ws As Worksheet
Dim wsCount As Long
wsCount = 0
For Each ws In Worksheets
printOrder = Application.VLookup(ws.Name, myrange, 4, False)
If Not IsError(printOrder) Then
If printOrder = "Y" Then
wsCount = wsCount + 1
ReDim Preserve wsArray(1 To wsCount)
'Add sheet to array
wsArray(wsCount) = ws.Name
End If
End If
Next
Sheets(wsArray).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, fileName:=sFileName, Quality _
:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=True
End Sub
edit: further explained context of my code to OP
Here is a bit of code I came up with. Basically you would want to take this and adapt it to fit your specific needs but the general idea should work!
Sub MovingPagesAccordingToNumberInRange()
Dim ws As Worksheet
Dim NextWs As Worksheet
Dim PreviousWs As Worksheet
Dim sheetNameArray(0 To 400) As String
Dim i As Integer
'This first loop is taking all of the sheets that have a number
' placed in the specified range (I used Cell A1 of each sheet)
' and it places the name of the worksheet into an array in the
' order that I want the sheets to appear. If I placed a 1 in the cell
' it will move the name to the 1st place in the array (location 0).
' and so on. It only places the name however when there is something
' in that range.
For Each ws In Worksheets
If ws.Cells(1, 1).Value <> Empty Then
num = ws.Cells(1, 1).Value - 1
sheetNameArray(num) = ws.Name
End If
Next
' This next section simply moves the sheets into their
' appropriate positions. It takes the name of the sheets in the
' previous spot in the array and moves the current spot behind that one.
' Since I didn't know how many sheets you would be using I just put
' A counter in the prevent an infinite loop. Basically if the loop encounters 200
' empty spots in the array, everything has probably been organized.
x = 1
Do While Count < 200
If sheetNameArray(x) <> Empty Then
Set PreviousWs = sheets(sheetNameArray(x - 1))
Set NextWs = sheets(sheetNameArray(x))
NextWs.Move after:=PreviousWs
x = x + 1
Else
Count = Count + 1
x = x + 1
End If
Loop
End Sub

VBA to copy another excel file contents to current workbook

This is what I want to achieve:
I want to copy the contents of the entire first sheet in the most recently modified excel file in a specified directory. I then want to paste the values of this copy operation to the first sheet of the current workbook.
I am aware there are macros to get the last modified file in a directory but I am unsure of a quick and clean way to implement this.
See below. This will use the current active workbook and look in C:\Your\Path for the Excel file with the latest modify date. It will then open the file and copy contents from the first sheet and paste them in your original workbook (on the first sheet):
Dim fso, fol, fil
Dim wkbSource As Workbook, wkbData As Workbook
Dim fileData As Date
Dim fileName As String, strExtension As String
Set wkbSource = ActiveWorkbook
Set fso = CreateObject("Scripting.FileSystemObject")
Set fol = fso.GetFolder("C:\Your\Path")
fileData = DateSerial(1900, 1, 1)
For Each fil In fol.Files
strExtension = fso.GetExtensionName(fil.Path)
If Left$(strExtension, 3) = "xls" Then
If (fil.DateLastModified > fileData) Then
fileData = fil.DateLastModified
fileName = fil.Path
End If
End If
Next fil
Set wkbData = Workbooks.Open(fileName, , True)
wkbData.Sheets(1).Cells.Copy
wkbSource.Sheets(1).Range("A1").PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
wkbData.Close
Set fso = Nothing
Set fol = Nothing
Set flc = Nothing
Set wkbData = Nothing
I had nothing better to do on my lunch - so here goes.
To fire it use: getSheetFromA()
Put this in the current file:
Dim most_recent_file(1, 2) As Variant
Sub getSheetFromA()
' STEP 1 - Delete first sheet in this workbook
' STEP 2 - Look through the folder and get the most recently modified file path
' STEP 3 - Copy the first sheet from that file to the start of this file
' STEP 1
' Delete the first sheet in the current file (named incase if deleting the wrong one..)
delete_worksheet ("Sheet1")
' STEP 2
' Now look for the most recent file
Dim folder As String
folder = "C:\Documents and Settings\Chris\Desktop\foldername\"
Call recurse_files(folder, "xls")
' STEP 3
Dim most_recently_modified_sheet As String
most_recently_modified_sheet = most_recent_file(1, 0)
getSheet most_recently_modified_sheet, 1
End Sub
Sub getSheet(filename As String, sheetNr As Integer)
' Copy a sheet from an external sheet to this workbook and put it first in the workbook.
Dim srcWorkbook As Workbook
Set srcWorkbook = Application.Workbooks.Open(filename)
srcWorkbook.Worksheets(sheetNr).Copy before:=ThisWorkbook.Sheets(1)
srcWorkbook.Close
Set srcWorkbook = Nothing
End Sub
Sub delete_worksheet(sheet_name)
' Delete a sheet (turn alerting off and on again to avoid prompts)
Application.DisplayAlerts = False
Sheets(sheet_name).Delete
Application.DisplayAlerts = True
End Sub
Function recurse_files(working_directory, file_extension)
With Application.FileSearch
.LookIn = working_directory
.SearchSubFolders = True
.filename = "*." & file_extension
.MatchTextExactly = True
.FileType = msoFileTypeAllFiles
If .Execute() > 0 Then
number_of_files = .FoundFiles.Count
For i = 1 To .FoundFiles.Count
vFile = .FoundFiles(i)
Dim temp_filename As String
temp_filename = vFile
' the next bit works by seeing if the current file is newer than the one in the array, if it is, then replace the current file in the array.
If (most_recent_file(1, 1) <> "") Then
If (FileLastModified(temp_filename) > most_recent_file(1, 1)) Then
most_recent_file(1, 0) = temp_filename
most_recent_file(1, 1) = FileLastModified(temp_filename)
End If
Else
most_recent_file(1, 0) = temp_filename
most_recent_file(1, 1) = FileLastModified(temp_filename)
End If
Next i
Else
MsgBox "There were no files found."
End If
End With
End Function
Function FileLastModified(strFullFileName As String)
' Taken from: http://www.ozgrid.com/forum/showthread.php?t=27740
Dim fs As Object, f As Object, s As String
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(strFullFileName)
s = f.DateLastModified
FileLastModified = s
Set fs = Nothing: Set f = Nothing
End Function