Automating Steps 2

[zdas04]

I've got about 70 Excel workbooks. Each one has the same 5 columns of data (generated by a computer) and the name of the worksheet is the meter number.

I open the file, add a column "A", double click on the sheet name, hit <cntl> "C", move to cell A2, hit <cntl> "V", hit <cntl> "C", move over to cell B2, hit <end> and the down arrow, move over to cell "A596" (or whatever it is), hold down the <shift> key, hit <end> and the up arrow, the move the cursor down to "A3" and hit <enter>. Then I put the cursor on "A2", hold the <shift> key down and go to the end of the data ("F596" or something like that) and hit <cntl> "C". Finally I go to an aggregate workbook and put the cursor on the next blank "A" cell ("A2" the first time, "A598" the second, etc.) and hit <enter>. Then I save the first file and close it.

Repeating this 70 times is more than a touch tedious. Can anyone think of a reasonable way to automate it? When I tried to record a macro, it didn't understand the double click on the sheet name step and crashed.

David

 

[MintJulep]

I can't follow what you are doing.

What do you have, and what do you want to end up with?

 

[zdas04]

What I have is 5 columns of hourly gas measurement data for each of 70 meters. I need to be able to syncronize all the meters across a time stamp (I need to be able to compare what the wells were making at noon on June 15 to what was sold at noon on June 15).

To do that I have to add a column for the meter number, populate it, and then load all the meters into an access database. The sheet (both the worksheet name and the file name) contain the meter number that I need. I want to automate the process of extracting the meter number and then populating it on the rows.

David

 

[IRstuff]

The sheet name code should look something like this:

SheetName = Sheets(1).Name
Range("A2").Select
ActiveSheet.Paste

I double clicked and copied the sheet name in the macro recorder without any problems, but the recorded code won't work in this specific case because it (the recorder) already knows the name of the sheet, and recorded this:

Sheets("test").Select
Sheets("test").Name = "test"
Range("A2").Select
ActiveSheet.Paste

Nonetheless, you can directly address a single-sheet workbook directly through the sheet index number as in the first snippet of code.

After that, you'd still need to wrap a loop around the code and come up with a way to automatically open each sheet that you need. You might check on Doug Jenkins' site and see if there's already some code for that. I know that the subject of accessing files in a folder has come up at least a couple of times in the past couple of years.

TTFN

FAQ731-376
Chinese prisoner wins Nobel Peace Prize

 

[MintJulep]

Try this:

'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
  Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Public Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type



Public Function GetDirectory(Optional Msg) As String
    Dim bInfo As BROWSEINFO
    Dim path As String
    Dim r As Long, x As Long, pos As Long
 
'   Root folder = Desktop
    bInfo.pidlRoot = 0&

'   Title in the dialog
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "Select a folder."
    Else
        bInfo.lpszTitle = Msg
    End If
    
'   Type of directory to return
    bInfo.ulFlags = &H1

'   Display the dialog
    x = SHBrowseForFolder(bInfo)
    
'   Parse the result
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        GetDirectory = Left(path, pos - 1)
    Else
        GetDirectory = ""
    End If
End Function
Sub MashFiles()
Dim oPath As String
Dim FileArray() As String
Dim oFileName As String
Dim NameNumShtRev As String
Dim i As Long
Dim myxlapp As Object
Dim usedrows As Long
Dim DestinationFile As String
Dim DestinationFolder As String
Dim MasterIndex As Excel.Workbook
Dim MasterSheet As Excel.Worksheet
Dim PartIndex As Excel.Workbook
Dim PartSheet As Excel.Worksheet


'Select the path containing the files to process
oPath = GetDirectory("Select the folder containing the files to process")
If oPath = "" Then
MsgBox "A folder was not selected"
Exit Sub
End If
'Set up a file to hold the composite
DestinationFile = InputBox("Name for Destination Spreadsheet")
If Right(DestinationFile, 4) <> ".xls" Then DestinationFile = DestinationFile & ".xls"

DestinationFolder = GetDirectory("Select a folder for the Destination Spreadsheet")

'open an Excel spreadsheet
Set myxlapp = CreateObject("Excel.Application")
Set MasterIndex = myxlapp.Workbooks.Add
Set MasterSheet = MasterIndex.Worksheets(1)
myxlapp.Visible = True

' Get the names of .xls files in oPath into an array.
ReDim FileArray(1 To 10000) 'A number larger the expected number of files

xlsName = Dir(oPath & "\*.xls")
Count = 0
Do Until xlsName = ""    ' Start the loop.
    Count = Count + 1
    ReDim Preserve FileArray(1 To Count)
    FileArray(Count) = xlsName
    xlsName = Dir ' Get next entry.
 Loop

For i = 1 To UBound(FileArray)
fullfilename = oPath & "\" & FileArray(i)
Set PartIndex = myxlapp.Workbooks.Open(fullfilename)
Set PartSheet = PartIndex.Sheets(1)
PartSheet.Columns("A:A").Insert shift:=xlToRight
For r = 1 To LastRow(PartSheet)
PartSheet.Cells(r, 1).Value = PartSheet.Name
Next r
PartSheet.UsedRange.Copy
MasterSheet.Range("A1").Cells(LastRow(MasterSheet) + 1, 1).PasteSpecial
PartIndex.Save
PartIndex.Close
Next i
MasterIndex.SaveAs (DestinationFolder & "\" & DestinationFile)
End Sub


Public Function LastRow(MySheet As Excel.Worksheet)
LastRow = MySheet.UsedRange.Rows.Count + MySheet.UsedRange.Row - 1
End Function

Frustratingly non-trivial. But some good exercise.

 

[zdas04]

WOW. I hope most of that was code you had laying around.

I copied it into a worksheet, but the "Function" line at the top won't compile (the rest was fine after I got rid of a bunch of "end" statements that got inserted). It highlights the "Lib" and gives me a pop-up box with "Compile error: Expected: end of statement" which I'm taking to mean that I'm missing a library or a path to a library.

Is this just a bone head noobie mistake or am I probably missing something? I learned my first programing language in 1978 and have learned 10 since, but I find myself looking at code a couple of times a year and the new stuff packs so much functionality into a single word that debugging can be a challenge.

David

 

[MintJulep]

I've need to do similar assimilation tasks before, so yea, most of that was on hand, and most of the rest was found on the web.

Start with an empty workbook.

Alt-F11 to open the VBA editor.

In the VBA editor screen select Insert from the top menu, then select Module.

Copy the code exactly as it appears above into the empty module.

Go back to the Excel screen.

Hit Alt-F8 and select "MashFiles" and click run.

Should run.

 

[zdas04]

I started over and did your steps exactly and still get the compile error on the "Lib" step in the first non-comment line. If I comment out the first two lines, it fails at the first call.

David

 

[MintJulep]

Try this. In the VBA Editor's Tools menu, click References... scroll down to "Microsoft Shell Controls And Automation" and select it.

 

[zdas04]

Same error. The window at the bottom of the References page says "Location: C:\WINDOWS\SYSTEM\SHELL32.dll" just like you'd expect from the line of code that is red. I closed excel a couple of times (even did an <alt> <cntl> <delete> and deleted the Excel.exe process after it said it was closed. No joy.

David

 

[MintJulep]

And if that didn't work then try this version. It uses a slightly different way, without the API calls, to browse for folders.

Function BrowseForFolder(Optional Openat As Variant, Optional prompt As String) As Variant
     'Function purpose:  To Browser for a user selected folder.
     'If the "OpenAt" path is provided, open the browser at that directory
     'NOTE:  If invalid, it will open at the Desktop level
     
    Dim ShellApp As Object
     
     'Create a file browser window at the default folder
    Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, prompt, 0, Openat)
     
     'Set the folder to that selected.  (On error in case cancelled)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.path
    On Error GoTo 0
     
     'Destroy the Shell Application
    Set ShellApp = Nothing
     
     'Check for invalid or non-entries and send to the Invalid error
     'handler if found
     'Valid selections can begin L: (where L is a letter) or
     '\\ (as in \\servername\sharename.  All others are invalid
    Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":"
        If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
    Case Is = "\"
        If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
    Case Else
        GoTo Invalid
    End Select
     
    Exit Function
     
Invalid:
     'If it was determined that the selection was invalid, set to False
    BrowseForFolder = False
     
End Function

Sub MashFiles()
Dim oPath As String
Dim FileArray() As String
Dim oFileName As String
Dim NameNumShtRev As String
Dim i As Long
Dim myxlapp As Object
Dim usedrows As Long
Dim DestinationFile As String
Dim DestinationFolder As String
Dim MasterIndex As Excel.Workbook
Dim MasterSheet As Excel.Worksheet
Dim PartIndex As Excel.Workbook
Dim PartSheet As Excel.Worksheet


'Select the path containing the files to process
oPath = GetDirectory(, "Select the folder containing the files to process")
If oPath = "" Then
MsgBox "A folder was not selected"
Exit Sub
End If
'Set up a file to hold the composite
DestinationFile = InputBox("Name for Destination Spreadsheet")
If Right(DestinationFile, 4) <> ".xls" Then DestinationFile = DestinationFile & ".xls"

DestinationFolder = GetDirectory(, "Select a folder for the Destination Spreadsheet")

'open an Excel spreadsheet
Set myxlapp = CreateObject("Excel.Application")
Set MasterIndex = myxlapp.Workbooks.Add
Set MasterSheet = MasterIndex.Worksheets(1)
myxlapp.Visible = True

' Get the names of .xls files in oPath into an array.
ReDim FileArray(1 To 10000) 'A number larger the expected number of files

xlsName = Dir(oPath & "\*.xls")
Count = 0
Do Until xlsName = ""    ' Start the loop.
    Count = Count + 1
    ReDim Preserve FileArray(1 To Count)
    FileArray(Count) = xlsName
    xlsName = Dir ' Get next entry.
 Loop

For i = 1 To UBound(FileArray)
fullfilename = oPath & "\" & FileArray(i)
Set PartIndex = myxlapp.Workbooks.Open(fullfilename)
Set PartSheet = PartIndex.Sheets(1)
PartSheet.Columns("A:A").Insert shift:=xlToRight
For r = 1 To LastRow(PartSheet)
PartSheet.Cells(r, 1).Value = PartSheet.Name
Next r
PartSheet.UsedRange.Copy
MasterSheet.Range("A1").Cells(LastRow(MasterSheet) + 1, 1).PasteSpecial
PartIndex.Save
PartIndex.Close
Next i
MasterIndex.SaveAs (DestinationFolder & "\" & DestinationFile)
End Sub


Public Function LastRow(MySheet As Excel.Worksheet)
LastRow = MySheet.UsedRange.Rows.Count + MySheet.UsedRange.Row - 1
End Function

Public Function GetDirectory(Optional Openat As Variant, Optional prompt As String) As String
GetDirectory = BrowseForFolder(Openat, prompt)
End Function

 

[zdas04]

Thanks, I'll try it in the morning, been a long day.

David

 

[zdas04]

Worked PERFECTLY. Thank you so much (sorry I can only give you one star in a thread).

David

 

[Qshake]

David - I've taken care of your one star problem....gave 'em one myself.

Way to go MJ.

Regards,
Qshake

Eng-Tips Forums:Real Solutions for Real Problems Really Quick.

 

[MintJulep]

Glad it worked out. I enjoyed the brain exercise.

 

[MintJulep]

Cleaned up a bit.

Broke the file name processing out into a Function.
Dimensioned all the variables used and only the variables used.

Should be tolerant of having other than .xls files in the process directory. (not tested)

Function BrowseForFolder(Optional OpenAt As Variant, Optional Prompt As String) As String
     'Function purpose:  To Browse for a user selected folder.
     'If the "OpenAt" path is provided, open the browser at that directory
     'If the "Promp" is provided it will appear below the dialog header bar.
     'NOTE:  If invalid, it will open at the Desktop level
     
    Dim ShellApp As Object
     
     'Create a file browser window at the default folder
    Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, Prompt, 0, OpenAt)
     
     'Set the folder to that selected.  (On error in case cancelled)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0
     
     'Destroy the Shell Application
    Set ShellApp = Nothing
     
     'Check for invalid or non-entries and send to the Invalid error
     'handler if found
     'Valid selections can begin L: (where L is a letter) or
     '\\ (as in \\servername\sharename.  All others are invalid
    Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":"
        If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
    Case Is = "\"
        If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
    Case Else
        GoTo Invalid
    End Select
     
    Exit Function
     
Invalid:
     'If it was determined that the selection was invalid, set to False
    BrowseForFolder = False
     
End Function


Public Function GetFileNames(oPath As String, Optional fExt As String) As String()

'Function Purpose:  Returns an array of the file names in the oPath directory.
'If the optional fExt is provided only files matching the extension are returned.
'If fExt is not provided then all files are returned.

Dim FileArray() As String
Dim fname As String
Dim SlashExt As String
Dim count As Integer

If fExt <> "" Then
    If Left(fExt, 1) = "." Then fExt = Right(fExt, Len(fExt) - 1) 'Allows fExt to be specified with or without "."
    SlashExt = "\*." & fExt
    
    Else
    SlashExt = "\*.*" 'Set extension to all if option fExt is not provided
    
End If

ReDim FileArray(1 To 2)

fname = Dir(oPath & SlashExt) 'Get first file name
count = 0
Do Until fname = ""    ' Start the loop.
    count = count + 1
    ReDim Preserve FileArray(1 To count)
    FileArray(count) = fname
    fname = Dir ' Get next entry.
 Loop
GetFileNames = FileArray
End Function

Public Function LastRow(MySheet As Excel.Worksheet) As Integer
LastRow = MySheet.UsedRange.Rows.count + MySheet.UsedRange.Row - 1
End Function

Sub MashFiles()

'Procedure Purpose:  Consolidate data from multiple spreadheets into a single spreadsheet.
'Works only with ActiveWorkBook.Sheets(1)
'For each of the multiple spreadsheets ActiveWorkBook.Sheets(1).Name is inserted into Column A of the consolidated sheet.

Dim aPath As String
Dim FileArray() As String
Dim i As Long
Dim r As Integer
Dim myxlapp As Object
Dim DestinationFile As String
Dim DestinationFolder As String
Dim MasterIndex As Excel.Workbook
Dim MasterSheet As Excel.Worksheet
Dim PartIndex As Excel.Workbook
Dim PartSheet As Excel.Worksheet


'Select the path containing the files to process and load .xls files into an array
aPath = BrowseForFolder(, "Select Folder with Files for Processing")
FileArray = GetFileNames(aPath, "xls")

'Set up a file to hold the composite
DestinationFile = InputBox("Name for Destination Spreadsheet")
If Right(DestinationFile, 4) <> ".xls" Then DestinationFile = DestinationFile & ".xls"
DestinationFolder = BrowseForFolder(, "Select a folder for the Destination Spreadsheet")

'open an Excel spreadsheet
Set myxlapp = CreateObject("Excel.Application")
Set MasterIndex = myxlapp.Workbooks.Add
Set MasterSheet = MasterIndex.Worksheets(1)
myxlapp.Visible = True

'Run though each file and do stuff
Application.ScreenUpdating = False
For i = 1 To UBound(FileArray)
    fullfilename = aPath & "\" & FileArray(i)
    Set PartIndex = myxlapp.Workbooks.Open(fullfilename)
    Set PartSheet = PartIndex.Sheets(1)
    PartSheet.Columns("A:A").Insert shift:=xlToRight
        For r = 1 To LastRow(PartSheet)
            PartSheet.Cells(r, 1).Value = PartSheet.Name
        Next r
    PartSheet.UsedRange.Copy
    MasterSheet.Range("A1").Cells(LastRow(MasterSheet) + 1, 1).PasteSpecial
    PartIndex.Save
    PartIndex.Close
Next i
MasterIndex.SaveAs (DestinationFolder & "\" & DestinationFile)
Application.ScreenUpdating = True
End Sub