I'm cycling through multiple Excel workbooks and worksheets in a chosen folder and pulling data from the sheets.
I want to allow users to Input sheetnames to include or exclude when looping through worksheets.
How can I create an input form that will allow choices between One of 3 options for multiple inputs:
Option1 - Only include sheets with these names (Quotes around sheetname, separate multiple sheet inputs by a comma then a space
(example: "Sheet2", "Sheet6", "Sheet10"), then provide User Input box.
Option2 - Exclude sheets with these names (Quotes around sheetname, but not sure how to separate them), Then provide User Input
box.
Option3 - Act on all worksheets
Is it possible to allow for wildcards with asterices (*)? (Not sure if that works with arrays?)
How can I pass those into vba commands like these:
Example code for Option1:
[CODE]
'For Each Sh In Sheets(Array("Sheet2", "Sheet6", "Sheet10"))
For Each Sh In Sheets(Array(uiSheetsIncluded))[/CODE]
Example codes for Option2 (These I'm not sure of):
[CODE]
'1) If sh Not Like "Sheet1" and sh Not Like "Sheet2" Then
If sh Not Like uiSheetsExcluded Then
'2) If sh <> "Sheet3" and sh <> "Sheet4" Then
If sh <> uiSheetsExcluded Then[/CODE]
Note: If you have part of the answer, ok too. Main thing I need help with is the input method.
My current macro works for Option3 only, and will loop through and copy from all sheets in all workbooks in a specified folder as selected through a browser dialog box.
Easy to recreate work book:
The Macro button is on the Destination sheet along with column headers (Will work with any column headers)
Module01_Merge_Data
[CODE]
'Description: Combines all files in a folder to a master file, one worksheet.
Sub MergeFiles()
Dim path As String, ThisWB As String, lngFilecounter As Long
Dim wbDest As Workbook, shtDest As Worksheet, ws As Worksheet
Dim Filename As String, Wkb As Workbook
Dim CopyRng As Range, Dest As Range
Dim RowofCopySheet As Integer
Dim uiFirstRow As Integer
Dim uiSheetname As String
Dim lngDefFRow As Long
Dim Response As Integer
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim lngLastRowcopy As Long
Dim lngColTab As Long
Dim lngLastCol As Long
Dim uiColTab As Integer
' Displays a message box with the yes and no options.
Response = MsgBox(prompt:="Do you know these?: You will be prompted for 1) First row # of data to copy (defaulted to first row under the header of this sheet), 2) Be able to browse to a folder containing ONLY the source documents, Select 'Yes' or 'No'.", Buttons:=vbYesNo)
' If statement to check if the yes button was selected.
If Response = vbYes Then
Else
' The no button was selected.
MsgBox "You selected 'No'. Will exit Macro. Please get source data's first row #, sheet name, and be able to browse to the folder containing the documents"
Exit Sub
End If
'Set default first row according to the activesheet
lngDefFRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
'Prompt select first row of data to copy (FYI: Type 1 is a number)
uiFirstRow = Application.InputBox("Input # of first Row of copy data under the header", "FIRST ROW UNDER HEADER", Default:=lngDefFRow, Type:=1)
RowofCopySheet = uiFirstRow ' Row to start copying data from (below the header)in the source sheets.
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'CAPTURING SHEETNAME (TAB)
'Set default column for captured Tab names as last column used range
lngColTab = LastCol(ActiveSheet)
'Prompt select column for captured Tab names (FYI: Type 1 is a number)
uiColTab = Application.InputBox("Input Column # to paste captured tab names in destination sheet, 0 if you don't want to capture them", _
"Last Column", Default:=lngColTab, Type:=1)
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
ThisWB = ActiveWorkbook.Name
path = GetDirectory("Select a folder containing Excel files you want to merge")
Application.EnableEvents = False
Application.ScreenUpdating = False
Set shtDest = ActiveWorkbook.ActiveSheet
Filename = Dir(path & "\*.xls", vbNormal)
If Len(Filename) = 0 Then
Application.EnableEvents = False
Application.ScreenUpdating = False
MsgBox "Cancelled folder selection, exiting Macro"
Exit Sub
Else
'Create input box for sheetname
'uiSheetname = Application.InputBox("Input Sheetname of Copy Data", "SHEETNAME OF COPY DATA", Default:=ActiveSheet.Name, Type:=2)
Do Until Filename = vbNullString
If Not Filename = ThisWB Then
Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename)
'############################################################################################################
For Each sh In Wkb.Worksheets
If sh.Name <> shtDest.Name Then
Wkb.Sheets(sh.Name).Activate
Wkb.Sheets(sh.Name).AutoFilterMode = False
'**NOTE:Usedrange can't find last row when usedrange does not begin on 1st row, so replacing this code:
lngLastRowcopy = LastRow(sh)
'PREV CODE: Set CopyRng = Wkb.Sheets(sh.Name).Range(Cells(RowofCopySheet, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))
Set CopyRng = Wkb.Sheets(sh.Name).Range(Cells(RowofCopySheet, 1), Cells(lngLastRowcopy, ActiveSheet.UsedRange.Columns.Count))
Set Dest = shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
'Find the last row with data on the ShtDest
Last = LastRow(shtDest)
'Test if there enough rows in the ShtDest to copy all the data
' If Last + CopyRng.Rows.Count > shtDest.Rows.Count Then
' MsgBox "There are not enough rows in the ShtDest"
' Exit Sub
' End If
CopyRng.Copy
Dest.PasteSpecial xlPasteValues
Dest.PasteSpecial xlPasteFormats
'^^^^^^^^^^^^^^^^^^^^^^'Optional: This will copy the sheet name into a column in destination sheet:
If uiColTab <> 0 Then
shtDest.Cells(Last + 1, uiColTab).Resize(CopyRng.Rows.Count).Value = sh.Name
'shtDest.Cells(Last + 1, "T").Resize(CopyRng.Rows.Count).Value = sh.Name 'note how can use letter for column
Else
End If
Application.CutCopyMode = False
End If
Next
'############################################################################################################
Wkb.Close False
End If
Filename = Dir()
Loop
End If
Range("A1").Select
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub[/CODE]
Module02_File_Browser
[CODE]Option Explicit
'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
Function GetDirectory(Optional msg) As String
On Error Resume Next
Dim bInfo As BrowseInfo
Dim path As String
Dim r As Long, x As Long, pos As Integer
'Root folder = Desktop
bInfo.pIDLRoot = 0&
'Title in the dialog
If IsMissing(msg) Then
bInfo.lpszTitle = "No Folder Selected" & vbCrLf & vbCrLf & "Please select the folder of the excel files to copy."
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
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function[/CODE]