Solved: Need to loop thru a folder of workbooks and extract customer addresses

[frank_m]

I need to loop through a folder that contains approximately 2,000 workbook's and extract the Customer name, Street address and Zip code

The Source Workbook Sheet Name = Packing Slip
B6 = Customer Name
B7 = Street address
B8 = City, State and Zip Code

* There may be a few where the info resides in (cells B7, B8, B9), or (B8, B9, B10) (It is ok to skip those and move to the next)

--------------------
Destination Workbook name is: Customer Addresses (Sheet Name = Sheet1)
(There will be many Duplicate rows of Customer address info, but that is fine as I know how filter those out)
Starting in cells A2, B2, C2
Column A Next Row = Customer Name
Column B Next Row = Street address
Column C Next Row = City, State and Zip Code

Thanks

[GTO]

...* There may be a few where the info resides in (cells B7, B8, B9), or (B8, B9, B10) (It is ok to skip those and move to the next)

Before trying to suggest code, what do you mean by 'skip those...'? If B6 is empty, we just close the wb and move on?

[frank_m]

yes exactly right, if B6 is empty close the workbook and move to the next workbook

Thanks

[GTO]

Not tested, try:

In a Standard Module (in the destination workbook):

Sub exa2()
Dim FSO         As Object '<-- FileSystemObject
Dim fsoFol      As Object '<-- Folder
Dim fsoFile     As Object '<-- File
Dim wb          As Workbook
Dim wksSource   As Worksheet
    
    '// Set references to FileSystemObject and the folder that this workbook        //
    '// resides in.                                                                 //
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set fsoFol = FSO.GetFolder(ThisWorkbook.Path & "\")
    
    
    For Each fsoFile In fsoFol.Files
        '// May need tuning, I do not have 2007+, but appears to catch all...       //
        If fsoFile.Type Like "Microsoft*Excel*Work*" _
        And Not fsoFile.Path = ThisWorkbook.FullName Then
            
            Set wb = Workbooks.Open(fsoFile.Path, False, True)
            
            '// Clear any previous reference                                        //
            Set wksSource = Nothing
            '// Disallow fatal error in case we do not find the sheet               //
            On Error Resume Next
            Set wksSource = wb.Worksheets("Packing Slip")
            
            '// Test to see if we found the sheet, as the reference will return     //
            '// Nothing if not Set.                                                 //
            If Not wksSource Is Nothing Then
                '// IF NOT cell is blank...                                         //
                If Not wksSource.Range("B6").Value = vbNullString Then
                    '// Faster than copy, just get vals.                            //
                    With ThisWorkbook.Worksheets("Sheet1")
                        .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Value _
                            = wksSource.Range("B6:D6").Value
                    End With
                End If
            End If
            '// Reset error handling                                                //
            On Error GoTo 0
            '// Close wb//
            wb.Close False
        End If
    Next
End Sub

The destination workbook would go in the same folder as all the files...

Hope that helps,

Mark

[frank_m]

HI Mark

Thanks a million for your help

I had to take out the bit that checks if it's an excel file as that wasn't working on my machine, but being that they all are excel files, it nearly works after I did that. - With the exception that some times get an error with the command wb.Close False

I temporarily dealt with that my including that command in the on error resume next

Only other issue is that it looks like I need switch to copy paste transpose or equivalent, as the source is "B6:B8", not "B6:D6",
and the destination is Column A, B, C. - I'll play with it a bit to see if I can figure it out.
[vba]With ThisWorkbook.Worksheets("Sheet1")
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Value _
= wksSource.Range("B6:D6").Value '<- should be "B6:B8"[/vba] :)

[GTO]

HI Mark

Thanks a million for your help

I had to take out the bit that checks if it's an excel file as that wasn't working on my machine, but being that they all are excel files, it nearly works after I did that. - With the exception that some times get an error with the command wb.Close False

I temporarily dealt with that my including that command in the on error resume next

Ouch, let's not mask the error if possible. Try a DoEvents right before wb.Close.

Only other issue is that it ooks like I need switch to copy paste transpose or equivalent, as the source is "B6:B8",

ACK! Sorry, OBBS kicking in... Try:

                    With ThisWorkbook.Worksheets("Sheet1")
                        .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Value _
                            = Application.Transpose(wksSource.Range("B6:B8").Value)
                    End With

[GTO]

I mean....

                    With ThisWorkbook.Worksheets("Sheet1")
                        .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(, 3).Value _
                            = Application.Transpose(wksSource.Range("B6:B8").Value)
                    End With

Hopefully you won't need a fire extinguisher for your PC...

[frank_m]

The transpose commands work, thanks for that

Even with the Doevents I'm get an error with the close command. Not on all workbooks though. (it's an automation error)

I'm puting together half a dozen sample workbooks, to put in a zip and attach for you to try. - I should have that ready in 5 or 10 minutes.

I am using Excel 2003

[frank_m]

After I changed the names of the workbook files to be strictly numeric names,
instead of a combination of alpha and numeric, the automation error vanished. (strange huhh??)

Only minor issue left that I have spotted is with the command to check if the file is an excel file before opening it. - On my machine, using your original commands, the macro exits without any processing. - I tried several variation's, such as *Excel* and a few others, but no luck.

No real need to fix it though, as I am sure they are all excel files.

Thanks again Mark. - This helps me out a lot.

Edit: The workbook name issue does also cause me to now need code to loop through the workbooks and change the names. ie: 1,2,3,4 and so on

Edit #2: Maybe it was spaces in the names that caused the error before I changed the names? - Do you think maybe?

[GTO]

You bet. I may not be able to read the answer until tomorrow, but maybe try this in a temp wb.

Sub exa()
Dim FSO As Object
Dim fsoFolder As Object
Dim fsoFile As Object
Dim fsoStream As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set fsoFolder = FSO.GetFolder(ThisWorkbook.Path & "\")
    Set fsoStream = FSO.CreateTextFile(ThisWorkbook.Path & "\Temp.txt", True)
    
    For Each fsoFile In fsoFolder.Files
        
        fsoStream.WriteLine fsoFile.Type
    Next
    
    fsoStream.Close
End Sub

It will create a text file with a file type listed for all the files in the folder (again, this tmp wb would go in the folder with all the other files.).

I just figured out that I missed the possibility of .csv files if you have those?

[frank_m]

Thanks Mark

I'm about ready to crash myself, so I think I'm not going to try anything now.

Yeah, a .csv file is possible.

If I'm lucky, maybe I'll see you at about the same time, same place, tomorrow.

[GTO]

Okay :-)

[frank_m]

Hi Mark,

I'm not concerned right now about checking the file type. We can mess with that after everything else is working.

Even though there is an On Error Resume Next, I'm getting a subscript out of range error if the sheet name does not exist.
[VBA]'// Disallow fatal error in case we do not find the sheet //
On Error Resume Next
Set wksSource = wb.Worksheets("Packing Slip")[/VBA]

[frank_m]

Hi Mark

I've attached the temp file that contains the file types. I went ahead and filtered out the duplicates.

I don't really need that though, as I just filter the .xls files, then copy them to a new folder. - If you're into it though, I would enjoy seeing how you use that. And I have a couple ideas for how I could use that type of code for other taks.

Below I highled the text below in brown my code comments showing some HACK's I made to you code,
what I did, as ugly as it is I know, has eliminated the errors I had been getting. This version works without changing the file names as I described in a previous post.

If you're into re-writing theclumbsy parts of my code, that would be great.
[vba]
Sub exa2()
Dim FSO As Object '<-- FileSystemObject
Dim fsoFol As Object '<-- Folder
Dim fsoFile As Object '<-- File
Dim wb As Workbook
Dim wksSource As Worksheet

'// Set references to FileSystemObject (scripting runtime) //
'// and the folder that this workbook resides in. //
Set FSO = CreateObject("Scripting.FileSystemObject")
Set fsoFol = FSO.GetFolder(ThisWorkbook.Path & "\")

For Each fsoFile In fsoFol.Files
'// May need tuning, I do not have 2007+, but appears to catch all...
']>>] Frank temporarily removed the command that checks if it is an Excel file
If Not fsoFile.Path = ThisWorkbook.FullName Then
']>>] Frank removed 2 parameters to eliminate error from wb.Close False & automation error
Set wb = Workbooks.Open(fsoFile.Path)
'Set wb = Workbooks.Open(fsoFile.Path, False, True)

']>>] Frank put this to handle an error from shared workbooks
With wb
If .MultiUserEditing Then
.ExclusiveAccess
.Save
End If
End With

'// Clear any previous reference //
Set wksSource = Nothing
'// Disallow fatal error in case we do not find the sheet //
On Error Resume Next
Set wksSource = wb.Worksheets("Out Side Purchase Order")

'// Test to see if we found the sheet, as the reference will return //
'// Nothing if not Set. //
If Not wksSource Is Nothing Then

']>>] Frank put this to handle if values start in B7 or B8
If wksSource.Range("B6").Value = "" Then
wksSource.Range("B6").Delete Shift:=xlUp
End If
If wksSource.Range("B6").Value = "" Then
wksSource.Range("B6").Delete Shift:=xlUp
End If

'// Faster than copy, just get vals. //
With ThisWorkbook.Worksheets("Sheet1")
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(, 3).Value _
= Application.Transpose(wksSource.Range("B6:B8").Value)
End With
End If

'End If
'// Reset error handling //
On Error GoTo 0
'// Close wb//
DoEvents
wb.Close False

End If
Next

MsgBox "Finished"
End Sub
[/vba]
Edit: the site is not letting me attach the text file so below I have pasted it's contents.

Adobe Acrobat Document
ODT# File
OpenDocument Text
HTML Application
Text Document
Shortcut
RTF File
Microsoft Word Document
JScript Script File
JPEG Image
Application
Microsoft Office Excel Comma Separated Values File
Windows Installer Package
TIFF Image
ISO File
GIF Image
Bitmap Image
Icon
XLS File
XPI File
XML Document
VBScript Script File
Microsoft Office Excel Worksheet
Compressed (zipped) Folder

[GTO]

Hi Frank,

A bit on-the-fly, but I tested against a small folder as well:

Microsoft Office Excel Comma Separated Values File
Microsoft Excel Worksheet
Microsoft Office Excel 2007 Workbook
Text Document
Microsoft Office Excel 2007 Macro-Enabled Workbook
Microsoft Excel Worksheet
Microsoft Excel Worksheet

As you mentioned, no worries currently for testing the file type, but I am not yet 'clueing in' as to what workbooks would not open other than csv's. I rarely use them, only once in a while to rip data from a csv, but I thought that the one sheet is always named (tab name) the same as the filename. If I have that part right, I would not see why you would want to open any csv's in the same folder, as at least per my pea brain, there could only be one in the folder with the right name...

If you want csv's to open, I would think this should work.

        If fsoFile.Type Like "Microsoft*Excel*" _
        And Not fsoFile.Path = ThisWorkbook.FullName Then

Reference:

            Set wb = Workbooks.Open(fsoFile.Path, False, True)

A bit of guessing, as I don't have access to 2007, and am a little under the weather to be thinking much, but maybe an added arg in newer ver, or maybe the shared workbooks caused? I even tested against a shared book, no issues, but regardless, certainly okay to ditch.

I don't really need that though, as I just filter the .xls files, then copy them to a new folder. - If you're into it though, I would enjoy seeing how you use that. And I have a couple ideas for how I could use that type of code for other taks.

Sorry, I'm sure its my foggy head, but not sure what you meant by "how you use that"? Presuming you mean checking if its an excel file before attempting to open, Like just uses simple patterns. If I'm way off, please say so...

I would change this:

        On Error Resume Next
        Set wksSource = wb.Worksheets("Out Side Purchase Order")
        On Error GoTo 0

...and ditch the On Error GoTo 0 farther down. That was my fault, as you have it as I did. In short, there should be no errors, excepting if the worksheet doesn't exist in the source. Thus - if we were to have an error, we'd be flying by it and not knowing...which can lead to big ol' headaches trying to figure out why/where something is going kaboom! IMO, On Error Resume Next should be allowed only to allow and error, test for it, and handle.

I do not see any clumsy parts and it sounds as though it is working. I am guessing that the sheet error was because you had a different sheet name? The only thing that strikes me is the deleting a cell at a time part...

I would try .Find, or, as shown below, Application.Match to find the first cell in B6:B8 that has data. Please note that I tossed in a Debug.Print. Open the Immediate Window, and maybe you can see what workbooks it fails to open. I hope you'll be able to test (no rush) cuz its bugging me that the pattern fails...

Sub exa3()
Dim FSO         As Object '<-- FileSystemObject
Dim fsoFol      As Object '<-- Folder
Dim fsoFile     As Object '<-- File
Dim wb          As Workbook
Dim wksSource   As Worksheet
Dim lStartRow   As Long
 
    '// Set references to FileSystemObject and the folder that this workbook        //
    '// resides in.                                                                 //
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set fsoFol = FSO.GetFolder(ThisWorkbook.Path & "\")
 
 
    For Each fsoFile In fsoFol.Files
 
        If fsoFile.Type Like "Microsoft*Excel*Work*" _
        And Not fsoFile.Path = ThisWorkbook.FullName Then
 
            Set wb = Workbooks.Open(fsoFile.Path)
 
            Debug.Print wb.Name
 
            Set wksSource = Nothing
            '// Disallow fatal error in case we do not find the sheet               //
            On Error Resume Next
            Set wksSource = wb.Worksheets("Out Side Purchase Order")
            On Error GoTo 0
 
            If Not wksSource Is Nothing Then
 
            '// IF we find somethig in B6 or B7 or B8                               //
                If Not IsError(Application.Match("*", wksSource.Range("B6:B8"), 0)) Then
                    With ThisWorkbook.Worksheets("Sheet1")
                        .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(, 3).Value _
                            = Application.Transpose( _
                                wksSource.Range("B5").Offset( _
                                    Application.Match("*", wksSource.Range("B6:B8"), 0)) _
                                        .Resize(3).Value)
                    End With
                End If
            End If
 
            '// Close wb//
            wb.Close False
        End If
    Next
End Sub

Hope that helps,

Mark

[GTO]

PS - Just FYI, to attach a textfile, you can zip it.

[frank_m]

HI Mark,

My mistake as far as what I was thinking you might use the text file for and thereby my interest in seeing how you went about using it. I was under the false impression that you were going to have excel search the text file for file types and somehow use that with the file type test before the open command..

The pattern match I basically understand, however with this type of implementation, it doesn't seem to work..(at least not on my machine)
I have only testing this with Excel 2003, so 2007 isn't the problem either.

The shared workbook thing I guess was a false alarm too, as your new code is handling them just fine.

I did have to change:
[vba]If fsoFile.Type Like "Microsoft*Excel*Work*" _
And Not fsoFile.Path = ThisWorkbook.FullName Then[/vba] To:
[vba] If Not fsoFile.Path = ThisWorkbook.FullName Then[/vba] and with that taken out now it runs like a champ.

I did discover a couple corrupted files from my previous testing. One would not open, the other opens but contains 100's, maybe 1,000's of garbled characters.

At the time it seemed that it was not those corrupted files though, as after it would error out, a workbook remained open which was a perfectly good file. In one case it was a shared file, so that's where I got the idea of that being an issue.

The sheet name difference is only because I run this in both a customer packing slip set of files in one folder and vendor purchase order files in another folder.

I love your code that handles the finding whether or not the three cell range of information start's in B6, B7 or B8

A bow of gratitude and respect being sent your way
and many thanks for your time, sharing of your skills and willingness to go the extra.mile.

-- Hope you're feeling better soon.

Frank

[GTO]

You are most welcome!