PDA

View Full Version : Integrate multiple filesd in a specific directory to one worksheet in a separate file



jqagsweb
11-11-2016, 05:45 AM
Ive had this macro working at different points and this was now not working on a 64bit office copy but was on a 32bit, is Ive changed it up yet again, but cannot get it to work

Everyday multiple POs come in with orders on them one line at a time. Those files all are named PO_Data*.xlsx which includes the identifying number of that PO

The end workbook is not stored in the same directory and it is named Print-master.xlsm

All of these PO's are stored in the orders folder in the users download directory with nothing else in the folder
Everything in this macro works except it is now not importing the file contents at all
I have everything auto filling down to row 150 and not the last row used but I can address that at a later time. Not importing makes it worthless

At this point the more I mess with it the more screwed up Im making it.

Any assistance is appreciated.

Sub MergeWOrders()
Dim path As String, ThisWB As String, lngFilecounter As Long
Dim wbDest As Workbook, shtDest As Worksheet, ws As Worksheet
Dim Filename As String, Wkb As Workbook
Dim CopyRng As Range, Dest As Range
Dim RowofCopySheet As Integer

RowofCopySheet = 2 ' Row Number from where you wish to start copying

ThisWB = ActiveWorkbook.Name
Sheets("WOrders").Select
Range("a2:ac150").Select
Selection.Delete Shift:=xlUp


'Path = ("USERPROFILE") & "\Downloads\orders"
ChDir Environ("USERPROFILE") & "\Downloads\"
sFile = Dir("orders")




Set shtDest = ActiveWorkbook.Sheets(1)
Filename = Dir(path & "PO_Data*.xlsx", vbNormal)
'If Len(Filename) = 0 Then Exit Sub
Do Until Filename = vbNullString
If Not Filename = ThisWB Then
Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename)
Set CopyRng = Wkb.Sheets(1).Range(Cells(RowofCopySheet, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))
Set Dest = shtDest.Range("B" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
CopyRng.Copy Dest
Wkb.Close False
End If

Filename = Dir()
Loop

'insert helper column
Range("A2").Select
ActiveCell.FormulaR1C1 = "1"
Range("A3").Select
ActiveCell.FormulaR1C1 = "2"
Range("A2:A3").Select
Selection.AutoFill Destination:=Range("A2:A150"), Type:=xlFillDefault
Range("A2:A150").Select

're-insert appropriate formulas
Sheets("WOrders").Select
Range("AD2").Select
ActiveCell.FormulaR1C1 = "=RC[-19]&"", ""&RC[-18]&"" ""&RC[-17]"
Range("AD2").Select
Selection.AutoFill Destination:=Range("AD2:AD150"), Type:=xlFillDefault
Range("AD2:AD150").Select
Range("AE2").Select
ActiveCell.FormulaR1C1 = "=RC[-14]&"" - ""&RC[-11]"
Range("AE2").Select
Selection.AutoFill Destination:=Range("AE2:AE150"), Type:=xlFillDefault
Range("AE2:AE150").Select

Sheets("Control Panel").Select
Range("A1").Select

Application.EnableEvents = True
Application.ScreenUpdating = True

MsgBox "PO's Merged & Ready to batch Print"
End Sub

Kenneth Hobs
11-12-2016, 10:45 AM
Please paste code between code tags. Insert code tags by clicking the # icon on the toolbar of a reply.

You have several things that could be improved. First, you need to resolve the path issue. After running this, check VBE's Immediate window for found filenames if any. If the window is not in view, select the option in VBE's View menu.


Sub MergeWOrders()
Dim path As String, ThisWB As String, lngFilecounter As Long
Dim wbDest As Workbook, shtDest As Worksheet, ws As Worksheet
Dim Filename As String, Wkb As Workbook
Dim CopyRng As Range, Dest As Range
Dim RowofCopySheet As Long, glb_origCalculationMode As Integer

On Error GoTo EndSub
With Application
glb_origCalculationMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
.Cursor = xlWait
.StatusBar = "Processing Order files.."
.EnableCancelKey = xlErrorHandler
End With

path = Environ("USERPROFILE") & "\Downloads\orders\"
If Len(Dir(path, vbDirectory)) = 0 Then
path = "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\" _
& "Explorer\User Shell Folders\{374DE290-123F-4565-9164-39C4925E467B}"
With CreateObject("WScript.Shell")
path = .ExpandEnvironmentStrings(.RegRead(path) & "\orders\")
End With
End If
If Len(Dir(path, vbDirectory)) = 0 Then
MsgBox "Downloads\Orders path could not be found.", vbCritical, "Macro Ending"
GoTo EndSub
End If

Filename = Dir(path & "PO_Data*.xlsx", vbNormal)
If Len(Filename) = 0 Then
MsgBox "No PO_Data*.xlsx file could be found.", vbCritical, "Macro Ending"
GoTo EndSub
End If

Do Until Filename = vbNullString
Debug.Print Filename
Filename = Dir()
Loop


EndSub:
With Application
.Calculation = glb_origCalculationMode
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.CalculateBeforeSave = True
.Cursor = xlDefault
.StatusBar = False
.EnableCancelKey = xlInterrupt
End With
End Sub