Merge Data from multiple files into Single xlsm- Debugging

[robertwp7472]

Hello All,

I have been working on my newest project and I am having Compile errors on the For/Next Loops and general Debugging issues.
Let me start by saying that I am very new to VBA coding and I am sure that my code is clunky and will have syntax errors.


What I am posting is my first attempt to construct code mostly on my own with help from borrowing snippets of code my previous projects and reorganizing it to the best of my ability. I know that some of it is probably incorrect or unnecessary at best but I tried to follow the path of programming logic in order to go step by step.


At this point I have gone as far as I can with my own skill set and lots of Google searching as well as seeking help from the Mr. Excel, Ozgrid, and ExcelGuru forums.


Please feel free to change any code as needed, but to enable my learning of what I did wrong I would like to request that you comment out my code while inserting yours.

Thank you all for any help on this.

Sub BuildXdock()

     '1.)Retrieve Data from Xdock Raw and Format
     
     '2.)Compare Item Number Data against PFAssingments.xlsx and retrieve PickFace
        'location data
        
     '3.)Compare Item Number Data against InventoryQuery.xlsx and retrieve Location of
        'oldest Lot for that item.
        
     '4.)Compare Item Number Data against Tacoma PSR.xlsx and retrive Product availability
        'data and cut code if any
        
     '5.)In relation to Step 2, if No Pickface is assigned email Inventory Team
        'to create New Pickface for item number
     
    Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook, wb4 As Workbook, wb5 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet, ws5 As Worksheet
    Dim wb2Loc As String, ws2Name As String
    Dim wb3Loc As String, ws3Name As String
    Dim wb4Loc As String, ws4Name As String
    Dim wb5Loc As String, ws5Name As String
    Dim lr As Long, R As Long, I As Long, N As Long, G As Long
    
        
Application.ScreenUpdating = False
Application.EnableEvents = False

'Change to your target workbook name
wb2Loc = "C:\Users\Family\My Documents\Dads\Work\XDock\Xdockrpt.xlsx"
'wb2loc = "S:\Warehouse\Tools\XDock\Xdockrpt.xlsx

wb3Loc = "C:\Users\Family\My Documents\Dads\Work\XDock\PFAssingments.xlsx"
'wb3loc = "S:\Warehouse\Tools\XDock\PFAssingments.xlsx

wb4Loc = "C:\Users\Family\My Documents\Dads\Work\XDock\InventoryQuery.xlsx"
'wb4loc = "S:\Warehouse\Tools\XDock\InventoryQuery.xlsx

wb5Loc = "C:\Users\Family\My Documents\Dads\Work\XDock\Tacoma PSR.xlsx"
'wb5loc = "S:\Warehouse\Tools\XDock\Tacoma PSR.xlsx


'Change to the sheet name you want to get specific data from
ws2Name = "Xdockrpt"
ws3Name = "PFAssingments"
ws4Name = "InventoryQuery"
ws5Name = "Tacoma PSR"

Set wb1 = ThisWorkbook
Set ws1 = wb1.ActiveSheet

Set wb2 = Workbooks.Open(Filename:=wb2Loc)
Set ws2 = wb2.Sheets(ws2Name)

Set wb3 = Workbooks.Open(Filename:=wb3Loc)
Set ws3 = wb3.Sheets(ws3Name)

Set wb4 = Workbooks.Open(Filename:=wb4Loc)
Set ws4 = wb4.Sheets(ws4Name)

Set wb5 = Workbooks.Open(Filename:=wb5Loc)
Set ws5 = wb5.Sheets(ws5Name)

'------------------------------
'|Begin Work with Raw Xdockrpt|
'------------------------------

'Remove any unneeded Rows/Colums from "Xdockrpt"
With ws2
    ActiveSheet.Cells.UnMerge
    Dim delrng As Range
    Dim Xsht As Range
        
    Set delrng = Range("A1:K7")
    Set Xsht = ActiveSheet.UsedRange
    
    lr = .Cells(Rows.Count, 1).End(xlUp).Row
    
    'Delete Rows 1-4, 6 & 7
    With delrng
      If .Cells(A) = "" Then .EntireRow.Delete
    End With
    
    'Delete Column G & Move current Column I to A
    With Xsht
       .Columns("G").Delete
       .Columns("I:I").Cut
       .Columns("A:A").Insert Shift:=xlToRight
    
    'Stuff has been moved, get new lr
    lr = .Cells(Rows.Count, 1).End(xlUp).Row
    
    'Create new header for I
       .Range("I1").Value = "PickFace"
       
    'Transfer desired Data from PFAssingments (ws3) to Xdockrpt (ws2)
     For R = .Cells(Rows.Count, 1).End(xlUp).Row To 3 Step -1
       If ws3.Range("B1:B" & lr).Value = ws2.Range("F2:F" & lr).Value Then
          ws3.Range("A1:A" & lr).Value.Copy
          ws2.Range("I2:I" & lr).Value.Paste
       Else: ws2.Range("I2:I" & lr).Value = "No Pickface"
       End If
     'Send Email to Inventory Control Team if "No Picface"
       If ws2.Range("I2:I" & lr).Value = "No Pickface" Then
       Call EmailIC
     Next R
      
     'Create new header for J
       .Range("J1").Value = "Get Old"
       
     'Transfer desired Data from InventoryQuery (ws4) to Xdockrpt (ws2)
     '----------------------------------------------------------------------
     '|On this set I am not sure how to code so that it only transfers the |
     '|information from ws4 that contains the oldest Lot Date and at the   |
     '|same time does not equal the Pick Face value already in "I" from the|
     '|previous function                                                   |
     '----------------------------------------------------------------------
     For I = .Cells(Rows.Count, 1).End(xlUp).Row To 3 Step -1
       If ws4.Range("D10:D" & lr).Value = ws2.Range("F2:F" & lr).Value Then
          ws4.Range("C10:C" & lr).Value.Copy 'Location of Oldest Lot Date
          ws2.Range("J2:J" & lr).Value.Paste
       End If
     Next I
     
     'Create new header for K
       .Range("K1").Value = "PSR Data"
       
     'Transfer Item Recovery Data from Tacoma PSR (ws5) to Xdockrpt (ws2)
     For N = .Cells(Rows.Count, 1).End(xlUp).Row To 3 Step -1
       If ws5.Range("A2:A" & lr).Value = ws2.Range("F2:F" & lr).Value Then
          ws5.Range("C2:C" & lr).Value.Copy
          ws2.Range("K2:K" & lr).Value.Paste
       End If
     Next N
     
     'Create new header for L
       .Range("L1").Value = "Cut Code"
     
     'Transfer Cut Codes from Tacoma PSR (ws5) to Xdockrpt (ws2)
     For G = .Cells(Rows.Count, 1).End(xlUp).Row To 3 Step -1
       If ws5.Range("A2:A" & lr).Value = ws2.Range("F2:F" & lr).Value Then
          ws5.Range("D2:C" & lr).Value.Copy
          ws2.Range("L2:L" & lr).Value.Paste
       End If
     Next G
     
     ' reset usedrange
       ActiveSheet.UsedRange
    End With
End With

' close the source workbook wb2
wb2.Close False

' |~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|
' | EVERYTHING FROM HERE ON IS DEALING WITH SHEET1 (AutoXrpt) |
' |~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|

Dim Br As Long

'Copy UedRange of Xdockrpt (ws2) to AutoXrpt (ws1)
ws2.UsedRange.Copy Destinaton:=ws1("A2")

With ws1
    ' reset usedrange, not really necessary, I just do it
    ' became necessary for the border formatting
    ActiveSheet.UsedRange
    
    'changes hav been made, get new lr
    lr = .Cells(Rows.Count, 1).End(xlUp).Row
    
    ' sort data by "Appointment Time" Then by "Order Number"
    With .Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("A2"), SortOn:=xlSortOnValues, _
                    Order:=xlAscending, DataOption:=xlSortTextAsNumbers
        .SortFields.Add Key:=Range("D2"), SortOn:=xlSortOnValues, _
                    Order:=xlAscending, DataOption:=xlSortTextAsNumbers
        .SetRange Range("A2:L" & lr)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    ' add a little formatting
    .Rows(1).Font.Bold = True
    .Cells.HorizontalAlignment = xlCenter
    .Cells.VerticalAlignment = xlCenter
    .Cells.EntireColumn.AutoFit
    
    ' Insert blank row between different order numbers
    lr = Cells(Rows.Count, 1).End(xlUp).Row
    For Br = lr - 1 To 3 Step -1
    If Cells(C, 1) <> Cells(C + 1, 1) Then
        Cells(C + 1, 1).EntireRow.Insert
        Range("A" & L + 1 & ":L" & L + 1).Interior.ColorIndex = 0
    End If
    Next Br
    
    ' apply borders to used range, but not row 1
    With .UsedRange.Offset(1).Resize(lr - 1).Borders
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    
End With
Application.ScreenUpdating = True

End Sub
Private Sub EmailIC()

'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'This macro adapted from: http://www.rondebruin.nl/win/s1/outlook/bmail4.htm

    Dim OutApp As Outlook.Application
    Dim OutMail As Outlook.MailItem
    Dim wb2Loc As String, wb2 As Workbook, ws2 As Worksheet, ws2Name As String
    Dim lr As Long
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(olMailItem)
    
    'Change to your target workbook name
    wb2Loc = "C:\Users\Family\My Documents\Dads\Work\XDock\Xdockrpt.xlsx"
    'wb2loc = "S:\Warehouse\Tools\XDock\Xdockrpt.xlsx
    ws2Name = "Xdockrpt"
    
    On Error Resume Next
    With OutMail
        .To = "jorge.morelles.contractor@pepsico.com"
        .CC = "cory.morrow.contractor@pepsico.com"
        .BCC = ""
        .Subject = "Need Pick Face please!"
        .Body = ws2.Range("F2:F" & lr).Value
        .Send
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

http://www.excelguru.ca/forums/showthread.php?6766-Merge-Data-from-multiple-files-into-Single-xlsm

http://www.ozgrid.com/forum/showthread.php?t=201249]Merge Data from multiple files into Single xlsm

 

[NotoriousPopol]

The principle difficulty of your code is the fast that you switch very often between sheets from different workbooks. This raises errors when you don't call properly the right sheet.

First mistake :

Set delrng=.Range("A1:K7")

Personnally I don't use 'With' a lot when I switch between several worksheets. It's confusing.

For exemple, you start with a "With ws2", and then "With Xsht" before closing your first With. I'm not sure if it raises an error but it's hard to read. Moreover, the Activesheet should not be called after many operations like this.

I would recommend to use "With" only if your following code impacts only one sheet.

 

[robertwp7472]

Thanks. Would I be able to use the commands like this:

IF delrng.Cells(A) = "" Then .EntireRow.Delete
End If

Xsht.Columns("G").Delete
Xsht.Columns("I:I").Cut
Xsht.Columns("A:A").Insert Shift:=xlToRight

Thereby eliminating the extra "With" statements?

 

[NotoriousPopol]

Yes. But maybe this is not what raises an error.

    If ws2.Range("I2:I" & lr).Value = "No Pickface" Then
        Call EmailIC
    End If
     Next R