Copying and pasting onto mastersheet but files have different formats (need if statement help)

F

faithtirta

New Member
Joined
May 1, 2023
Messages
7
Office Version
  1. 365
Platform
  1. Windows
Hi all,

I am needing assistance with my code. I need the macro to go through files in a folder that contain vendor contact forms. I need to copy certain cells from each file (there are hundreds of files) and paste them into a master sheet. The fomats of the vendor contact files are different in which format 1 has First name and Last name combined into one column (B12:B16) while format 2 has first name and last name separated into two columns but in the master sheet I want the first name and last name to be in two seperate files,

Not only that but format 1 has contact information starting on A12:E12 and ending on A16:E16. However, in format 2 contact information begins on A13:F13 and ends A19:F19. Column A corresponds to Position in the Master sheet. Vendor inormation is consistent throughout the files. The end goal for the macro is to go through each file and pull the vebdor information adn the contacts for each vendor into a mastersheet (as shown in the screenshot). For each contact I need the basic vendor information to correspond to the vendor that the contact is for. I am wanting to use this macro so that whenever I have a new vendor contact form I can place it in the folder and run the macro so that it adds to the next available row on the Mastersheet.

1683750517258.png

Cell References that are consistent for both formats:
Vendor Name: B4:C4
Address 1: B5:C5
Address 2: B6:C6
City, State, Zip: B7:C7
Main Office Phone B8:C8

Attached is the code that I am using in which this code is very slow and only copies the very last contact information on the form and disregards the contacts before it. This code also only works with the format 2 not format 1. Please help - I have tried avoiding copying cells and just make the target range value equal the source range value but that code was not successful in pulling any information. I believe an if statement is required for the different formatting but I can't figure out how to go about it.

VBA Code: 
Private Sub VendorContactMacro()

   Dim strPath As String
   Dim strFile As String
   Dim wbSource As Workbook
   Dim wsSource As Worksheet
   Dim wsTarget As Worksheet
   Dim LastRow As Long
  
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  
   strPath = "\\usdls7erfs02\group$\Merchandising\Merchandising\Merchandising Supplier Support\New Vendors\!!New Vendors\Completed Vendors\JENNIFER FILE FOR VENDOR CONTACTS\VENDOR CONTACT FORMS"
   If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
 
   'set the target worksheet
   Set wsTarget = ActiveWorkbook.Worksheets("Master Sheet 2")
 
  
   'get the first file
   strFile = Dir(strPath & "*.xlsx*")
  
   'loop throught the excel files in the folder
   Do While strFile <> ""

         'open the workbook
         Set wbSource = Workbooks.Open(strPath & strFile)
         Set wsSource = wbSource.Worksheets(1)
         
         'set last row
         LastRow = wsTarget.Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
         
         'copy and paste
            wsSource.Range("B4:C4").Copy
            wsTarget.Cells(LastRow, 1).PasteSpecial xlPasteValues
            wsSource.Range("B5:C5").Copy
            wsTarget.Cells(LastRow, 2).PasteSpecial xlPasteValues
            wsSource.Range("B6:C6").Copy
            wsTarget.Cells(LastRow, 3).PasteSpecial xlPasteValues
            wsSource.Range("B7:C7").Copy
            wsTarget.Cells(LastRow, 4).PasteSpecial xlPasteValues
            wsSource.Range("B8:C8").Copy
            wsTarget.Cells(LastRow, 5).PasteSpecial xlPasteValues
            wsSource.Range("A13").Copy
            wsTarget.Cells(LastRow, 6).PasteSpecial xlPasteValues
            wsSource.Range("B13").Copy
            wsTarget.Cells(LastRow, 7).PasteSpecial xlPasteValues
            wsSource.Range("C13").Copy
            wsTarget.Cells(LastRow, 8).PasteSpecial xlPasteValues
            wsSource.Range("D13").Copy
            wsTarget.Cells(LastRow, 9).PasteSpecial xlPasteValues
            wsSource.Range("E13").Copy
            wsTarget.Cells(LastRow, 10).PasteSpecial xlPasteValues
            wsSource.Range("F13").Copy
            wsTarget.Cells(LastRow, 11).PasteSpecial xlPasteValues
            wsSource.Range("A14").Copy
            wsTarget.Cells(LastRow, 6).PasteSpecial xlPasteValues
            wsSource.Range("B14").Copy
            wsTarget.Cells(LastRow, 7).PasteSpecial xlPasteValues
            wsSource.Range("C14").Copy
            wsTarget.Cells(LastRow, 8).PasteSpecial xlPasteValues
            wsSource.Range("D14").Copy
            wsTarget.Cells(LastRow, 9).PasteSpecial xlPasteValues
            wsSource.Range("E14").Copy
            wsTarget.Cells(LastRow, 10).PasteSpecial xlPasteValues
            wsSource.Range("F14").Copy
            wsTarget.Cells(LastRow, 11).PasteSpecial xlPasteValues
            wsSource.Range("A15").Copy
            wsTarget.Cells(LastRow, 6).PasteSpecial xlPasteValues
            wsSource.Range("B15").Copy
            wsTarget.Cells(LastRow, 7).PasteSpecial xlPasteValues
            wsSource.Range("C15").Copy
            wsTarget.Cells(LastRow, 8).PasteSpecial xlPasteValues
            wsSource.Range("D15").Copy
            wsTarget.Cells(LastRow, 9).PasteSpecial xlPasteValues
            wsSource.Range("E15").Copy
            wsTarget.Cells(LastRow, 10).PasteSpecial xlPasteValues
            wsSource.Range("F15").Copy
            wsTarget.Cells(LastRow, 11).PasteSpecial xlPasteValues
            wsSource.Range("A16").Copy
            wsTarget.Cells(LastRow, 6).PasteSpecial xlPasteValues
            wsSource.Range("B16").Copy
            wsTarget.Cells(LastRow, 7).PasteSpecial xlPasteValues
            wsSource.Range("C16").Copy
            wsTarget.Cells(LastRow, 8).PasteSpecial xlPasteValues
            wsSource.Range("D16").Copy
            wsTarget.Cells(LastRow, 9).PasteSpecial xlPasteValues
            wsSource.Range("E16").Copy
            wsTarget.Cells(LastRow, 10).PasteSpecial xlPasteValues
            wsSource.Range("F16").Copy
            wsTarget.Cells(LastRow, 11).PasteSpecial xlPasteValues
            wsSource.Range("A17").Copy
            wsTarget.Cells(LastRow, 6).PasteSpecial xlPasteValues
            wsSource.Range("B17").Copy
            wsTarget.Cells(LastRow, 7).PasteSpecial xlPasteValues
            wsSource.Range("C17").Copy
            wsTarget.Cells(LastRow, 8).PasteSpecial xlPasteValues
            wsSource.Range("D17").Copy
            wsTarget.Cells(LastRow, 9).PasteSpecial xlPasteValues
            wsSource.Range("E17").Copy
            wsTarget.Cells(LastRow, 10).PasteSpecial xlPasteValues
            wsSource.Range("F17").Copy
            wsTarget.Cells(LastRow, 11).PasteSpecial xlPasteValues
            wsSource.Range("A18").Copy
            wsTarget.Cells(LastRow, 6).PasteSpecial xlPasteValues
            wsSource.Range("B18").Copy
            wsTarget.Cells(LastRow, 7).PasteSpecial xlPasteValues
            wsSource.Range("C18").Copy
            wsTarget.Cells(LastRow, 8).PasteSpecial xlPasteValues
            wsSource.Range("D18").Copy
            wsTarget.Cells(LastRow, 9).PasteSpecial xlPasteValues
            wsSource.Range("E18").Copy
            wsTarget.Cells(LastRow, 10).PasteSpecial xlPasteValues
            wsSource.Range("F18").Copy
            wsTarget.Cells(LastRow, 11).PasteSpecial xlPasteValues
            wsSource.Range("A19").Copy
            wsTarget.Cells(LastRow, 6).PasteSpecial xlPasteValues
            wsSource.Range("B19").Copy
            wsTarget.Cells(LastRow, 7).PasteSpecial xlPasteValues
            wsSource.Range("C19").Copy
            wsTarget.Cells(LastRow, 8).PasteSpecial xlPasteValues
            wsSource.Range("D19").Copy
            wsTarget.Cells(LastRow, 9).PasteSpecial xlPasteValues
            wsSource.Range("E19").Copy
            wsTarget.Cells(LastRow, 10).PasteSpecial xlPasteValues
            wsSource.Range("F19").Copy
            wsTarget.Cells(LastRow, 11).PasteSpecial xlPasteValues
         
         wbSource.Close SaveChanges:=False

      'get the next file
      strFile = Dir()
   Loop
  
   MsgBox ("Done")
  
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

I have attached both vendor contat formats - I cant figure out how to use xl2bb its not letting me copy anything - mini sheet and table only is grayed out (see screenshot below). I also do not have a dropbox account so I cant attach any actual files - if anyone needs the files and wants to help please reach out.
1683757907491.png

Vendor contact form format 1:
1683757944599.png

Vendor contact form format 2:
1683758028721.png

Master Sheet Format:
1683758100502.png
 

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.
Sort by date Sort by votes
Working on the If logic, but to set one cell equal to another cell value you should be able to use the following:
VBA Code: 
wsTarget.Cells(LastRow, 1).Value = wsSource.Range("B4").Value

It should be faster to read to an array and then write from the array. It also could clean up the code a bit.

Can you have varying lines of contacts per company? For example, one company may have 3 and another may have 6?
 
Upvote 0
NateSC said:
Working on the If logic, but to set one cell equal to another cell value you should be able to use the following:
VBA Code: 
wsTarget.Cells(LastRow, 1).Value = wsSource.Range("B4").Value

It should be faster to read to an array and then write from the array. It also could clean up the code a bit.

Can you have varying lines of contacts per company? For example, one company may have 3 and another may have 6?
Click to expand...
Hi Nate,

Thank you so much this made it run so much faster. However, I am still having the issue where its only copying the very last contact instead of all of the contacts.

Yes there can be varying lines of contacts per company because of how each vendor contact form is formatted some may have 5 or some may have 6. I appreicate you helping out. Let me know if you have any more questions!
 
Upvote 0
Yes, your code is telling it to overwrite the same cell multiple times. You need a way to vary the row when you move to the second contact. For example, you call "wsTarget.Cells(LastRow, 6).PasteSpecial xlPasteValues" multiple times. Each time, it is writing to the 6th column on the "LastRow". When you process the second contact, you really want it to copy to "Last Row + 1". With your current code, you need a few things: figure out how many contacts are on the sheet, set up a loop to go through each on, use the loop counter to add to the "LastRow".

(Almost done with my version. Just debugging a couple of issues.)
 
Upvote 0
NateSC said:
Yes, your code is telling it to overwrite the same cell multiple times. You need a way to vary the row when you move to the second contact. For example, you call "wsTarget.Cells(LastRow, 6).PasteSpecial xlPasteValues" multiple times. Each time, it is writing to the 6th column on the "LastRow". When you process the second contact, you really want it to copy to "Last Row + 1". With your current code, you need a few things: figure out how many contacts are on the sheet, set up a loop to go through each on, use the loop counter to add to the "LastRow".

(Almost done with my version. Just debugging a couple of issues.)
Click to expand...
I see, I figured that was the issue but just did not know how to fix it. Thank you so much, looking forward to seeing your version. I really appreciate it.
 
Upvote 0
OK. I tried to find an easier method to split the text, but ended up doing a nested loop. It still works pretty fast. I put comments around the new section of code. Also, this uses column A to determine the number of contacts. If there are cases where A could be blank, uncomment the line that looks at column B (See !!!! below). Try this:
VBA Code: 
Private Sub VendorContactMacro()

   Dim strPath As String
   Dim strFile As String
   Dim wbSource As Workbook
   Dim wsSource As Worksheet
   Dim wsTarget As Worksheet
   Dim LastRow As Long
  
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  
   strPath = "\\usdls7erfs02\group$\Merchandising\Merchandising\Merchandising Supplier Support\New Vendors\!!New Vendors\Completed Vendors\JENNIFER FILE FOR VENDOR CONTACTS\VENDOR CONTACT FORMS"
   If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
 
   'set the target worksheet
   Set wsTarget = ActiveWorkbook.Worksheets("Master Sheet 2")
 
  
   'get the first file
   strFile = Dir(strPath & "*.xlsx*")
  
   'loop throught the excel files in the folder
   Do While strFile <> ""

         'open the workbook
         Set wbSource = Workbooks.Open(strPath & strFile)
         Set wsSource = wbSource.Worksheets(1)
         
         'set last row
         LastRow = wsTarget.Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
         
         'copy and paste
'**** New CODE BELOW HERE
'**** You can move the declarations to the top if you would like
    
Dim myHeader As Variant
Dim myData As Variant
Dim outArray() As Variant
Dim needSplit As Boolean
Dim myRow As Integer
Dim i As Integer
Dim k As Integer
Dim m As Integer
Dim v As Variant
Dim myCount As Integer

        ' Grab all the Company Information at the top
        myHeader = Application.WorksheetFunction.Transpose(wsSource.Range("B4:B8").Value)
        
        ' This is the logic to determine which Format of form is used.
        If wsSource.Range("B12") = "First Name" Then
            ' Fits format 2
            myRow = 13
            needSplit = False
        Else
            ' Fits format 1
            myRow = 12
            needSplit = True
        End If
            
        ' !!!!!! Get a count of contacts - UsesColumn A to get the count
        myCount = wsSource.Cells(Rows.Count, 1).End(xlUp).Row - myRow

        ' !!!!!! Get a count of contacts - UsesColumn B to get the count
        'myCount = wsSource.Cells(Rows.Count, 2).End(xlUp).Row - myRow
        
        ' Grab the data for the contacts and store it in an array
        myData = wsSource.Range("A" & myRow & ":F" & wsSource.Cells(Rows.Count, 1).End(xlUp).Row).Value
        
        ' If it needs to split the txt, then process element by element, otherwise move directly to outArray
        If needSplit Then
            ReDim outArray(myCount, 6)
            For k = 0 To myCount
                For m = 0 To 5
                    Select Case m
                    Case 0
                        outArray(k, m) = myData(k + 1, m + 1)
                    Case 1
                        v = Split(myData(k + 1, m + 1))
                        outArray(k, m) = v(0)
                    Case 2
                        v = Split(myData(k + 1, m))
                        outArray(k, m) = v(1)
                    Case 3, 4, 5
                        outArray(k, m) = myData(k + 1, m)
                    End Select
                Next m
            Next k
        Else
            outArray = myData
        End If
        
        ' Write data to the master sheet
        wsTarget.Range("A" & LastRow & ":E" & LastRow + myCount).Value = myHeader
        wsTarget.Range("F" & LastRow & ":K" & LastRow + myCount).Value = outArray
        
        Erase outArray
    
' ***** END OF NEW CODE
         
         wbSource.Close SaveChanges:=False

      'get the next file
      strFile = Dir()
   Loop
  
   MsgBox ("Done")
  
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub
 
Upvote 0
NateSC said:
OK. I tried to find an easier method to split the text, but ended up doing a nested loop. It still works pretty fast. I put comments around the new section of code. Also, this uses column A to determine the number of contacts. If there are cases where A could be blank, uncomment the line that looks at column B (See !!!! below). Try this:
VBA Code: 
Private Sub VendorContactMacro()

   Dim strPath As String
   Dim strFile As String
   Dim wbSource As Workbook
   Dim wsSource As Worksheet
   Dim wsTarget As Worksheet
   Dim LastRow As Long
 
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
 
   strPath = "\\usdls7erfs02\group$\Merchandising\Merchandising\Merchandising Supplier Support\New Vendors\!!New Vendors\Completed Vendors\JENNIFER FILE FOR VENDOR CONTACTS\VENDOR CONTACT FORMS"
   If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
 
   'set the target worksheet
   Set wsTarget = ActiveWorkbook.Worksheets("Master Sheet 2")
 
 
   'get the first file
   strFile = Dir(strPath & "*.xlsx*")
 
   'loop throught the excel files in the folder
   Do While strFile <> ""

         'open the workbook
         Set wbSource = Workbooks.Open(strPath & strFile)
         Set wsSource = wbSource.Worksheets(1)
        
         'set last row
         LastRow = wsTarget.Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
        
         'copy and paste
'**** New CODE BELOW HERE
'**** You can move the declarations to the top if you would like
   
Dim myHeader As Variant
Dim myData As Variant
Dim outArray() As Variant
Dim needSplit As Boolean
Dim myRow As Integer
Dim i As Integer
Dim k As Integer
Dim m As Integer
Dim v As Variant
Dim myCount As Integer

        ' Grab all the Company Information at the top
        myHeader = Application.WorksheetFunction.Transpose(wsSource.Range("B4:B8").Value)
       
        ' This is the logic to determine which Format of form is used.
        If wsSource.Range("B12") = "First Name" Then
            ' Fits format 2
            myRow = 13
            needSplit = False
        Else
            ' Fits format 1
            myRow = 12
            needSplit = True
        End If
           
        ' !!!!!! Get a count of contacts - UsesColumn A to get the count
        myCount = wsSource.Cells(Rows.Count, 1).End(xlUp).Row - myRow

        ' !!!!!! Get a count of contacts - UsesColumn B to get the count
        'myCount = wsSource.Cells(Rows.Count, 2).End(xlUp).Row - myRow
       
        ' Grab the data for the contacts and store it in an array
        myData = wsSource.Range("A" & myRow & ":F" & wsSource.Cells(Rows.Count, 1).End(xlUp).Row).Value
       
        ' If it needs to split the txt, then process element by element, otherwise move directly to outArray
        If needSplit Then
            ReDim outArray(myCount, 6)
            For k = 0 To myCount
                For m = 0 To 5
                    Select Case m
                    Case 0
                        outArray(k, m) = myData(k + 1, m + 1)
                    Case 1
                        v = Split(myData(k + 1, m + 1))
                        outArray(k, m) = v(0)
                    Case 2
                        v = Split(myData(k + 1, m))
                        outArray(k, m) = v(1)
                    Case 3, 4, 5
                        outArray(k, m) = myData(k + 1, m)
                    End Select
                Next m
            Next k
        Else
            outArray = myData
        End If
       
        ' Write data to the master sheet
        wsTarget.Range("A" & LastRow & ":E" & LastRow + myCount).Value = myHeader
        wsTarget.Range("F" & LastRow & ":K" & LastRow + myCount).Value = outArray
       
        Erase outArray
   
' ***** END OF NEW CODE
        
         wbSource.Close SaveChanges:=False

      'get the next file
      strFile = Dir()
   Loop
 
   MsgBox ("Done")
 
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub
Click to expand...
Hi, I appreciate it - the code works so much faster and sucessfully goes through some of the files. However, I am getting a runtime error 9: subscript out of range for forms that have a blank contact row. I forgot to mention but there are cases where some contacts are blank but a position is there the company just did not put a contact on the form. Is there anyway to tweak the code to go around this or should I just go in and manually put N/A for the ones that are blank.
1683832078095.png

1683832362008.png
 
Upvote 0
Change Case 1 and 2 to this:
VBA Code: 
                    Case 1
                        If myData(k + 1, m + 1) = "" Then
                            v = Array("", "")
                        Else
                            v = Split(myData(k + 1, m + 1))
                        End If
                        outArray(k, m) = v(0)
                    Case 2
                        If myData(k + 1, m) = "" Then
                            v = Array("", "")
                        Else
                            v = Split(myData(k + 1, m))
                        End If
                        outArray(k, m) = v(1)
 
Upvote 0
Solution
faithtirta said:
Hi, I appreciate it - the code works so much faster and sucessfully goes through some of the files. However, I am getting a runtime error 9: subscript out of range for forms that have a blank contact row. I forgot to mention but there are cases where some contacts are blank but a position is there the company just did not put a contact on the form. Is there anyway to tweak the code to go around this or should I just go in and manually put N/A for the ones that are blank.
View attachment 91464
View attachment 91466
Click to expand...
I am actually not sure what is causing this error - I had originally thought it was due to some rows/columns being blank but i had filled in the empty cells with N/A but it still is giving me a run time error for that specific line.
 
Upvote 0
It breaks because you do not have a space which yields 2 names. You could always put "n/a n/a" and it would work.

It might also break if there are cases where you only have a single name (either just first or last).
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

F
  • Question
Macro that copies and pastes from each file into formatted master sheet with merged cells
Replies
1
Views
792
OaklandJim
O
T
  • Question
Copy row values from one worksheet in one workbook to multiple workbooks based on file name
Replies
0
Views
160
thechad
T
Y
  • Question
sum total in specific column when it complete 1 quantity in column H
Replies
0
Views
277
yoon
Y
D
  • Solved
Copy/Paste Values multiple outputs with different sizes into one single Excel sheet using VBA
Replies
2
Views
491
daisylee
D
P
  • Question
Edit VBA code to add new attachment on Email
Replies
3
Views
276
Persl
P

Forum statistics

Threads
1,214,904
Messages
6,122,169
Members
449,070
Latest member
webster33

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top