Automating Steps
Automating Steps
(OP)
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
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





RE: Automating Steps
What do you have, and what do you want to end up with?
RE: Automating Steps
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
RE: Automating Steps
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: Eng-Tips.com Forum Policies
Chinese prisoner wins Nobel Peace Prize
RE: Automating Steps
CODE
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
RE: Automating Steps
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
RE: Automating Steps
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.
RE: Automating Steps
David
RE: Automating Steps
RE: Automating Steps
David
RE: Automating Steps
CODE
'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
RE: Automating Steps
David
RE: Automating Steps
David
RE: Automating Steps
Way to go MJ.
Regards,
![[pipe] pipe](https://www.tipmaster.com/images/pipe.gif)
Qshake
Eng-Tips Forums:Real Solutions for Real Problems Really Quick.
RE: Automating Steps
RE: Automating Steps
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)
CODE
'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