Post-19 Delete Consecutive row in Excel Macros:
Sub deleteeveryotherrow()
For x = 1 To 100 Step 1
Rows(x & ":" & x).Select
Selection.Delete Shift:=xlUp
Next x
End SubPost-18 Merge different excel workbooks into a single workbook into different sheets:Sub MergeExcelFiles()
Dim fnameList, fnameCurFile As Variant
Dim countFiles, countSheets As Integer
Dim wksCurSheet As Worksheet
Dim wbkCurBook, wbkSrcBook As Workbook
fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)
If (vbBoolean <> VarType(fnameList)) Then
If (UBound(fnameList) > 0) Then
countFiles = 0
countSheets = 0
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set wbkCurBook = ActiveWorkbook
For Each fnameCurFile In fnameList
countFiles = countFiles + 1
Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)
For Each wksCurSheet In wbkSrcBook.Sheets
countSheets = countSheets + 1
wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
Next
wbkSrcBook.Close SaveChanges:=False
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
End If
Else
MsgBox "No files selected", Title:="Merge Excel files"
End If
End SubPost-17 Combine all Sheets into one Master Sheet in Excel Macros:Sub Consolidate_Data_From_Different_Sheets_Into_Single_Sheet()
'Procedure to Consolidate all sheets in a workbook
On Error GoTo IfError
'1. Variables declaration
Dim Sht As Worksheet, DstSht As Worksheet
Dim LstRow As Long, LstCol As Long, DstRow As Long
Dim i As Integer, EnRange As String
Dim SrcRng As Range
'2. Disable Screen Updating - stop screen flickering
' And Disable Events to avoid inturupted dialogs / popups
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'3. Delete the Consolidate_Data WorkSheet if it exists
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Sheets("Consolidate_Data").Delete
Application.DisplayAlerts = True
'4. Add a new WorkSheet and name as 'Consolidate_Data'
With ActiveWorkbook
Set DstSht = .Sheets.Add(After:=.Sheets(.Sheets.Count))
DstSht.Name = "Consolidate_Data"
End With
'5. Loop through each WorkSheet in the workbook and copy the data to the 'Consolidate_Data' WorkSheet
For Each Sht In ActiveWorkbook.Worksheets
If Sht.Name <> DstSht.Name Then
'5.1: Find the last row on the 'Consolidate_Data' sheet
DstRow = fn_LastRow(DstSht) + 1
'5.2: Find Input data range
LstRow = fn_LastRow(Sht)
LstCol = fn_LastColumn(Sht)
EnRange = Sht.Cells(LstRow, LstCol).Address
Set SrcRng = Sht.Range("A1:" & EnRange)
'5.3: Check whether there are enough rows in the 'Consolidate_Data' Worksheet
If DstRow + SrcRng.Rows.Count > DstSht.Rows.Count Then
MsgBox "There are not enough rows to place the data in the Consolidate_Data worksheet."
GoTo IfError
End If
'5.4: Copy data to the 'consolidated_data' WorkSheet
SrcRng.Copy Destination:=DstSht.Range("A" & DstRow)
End If
Next
IfError:
'6. Enable Screen Updating and Events
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
'In this example we are finding the last Row of specified Sheet
Function fn_LastRow(ByVal Sht As Worksheet)
Dim lastRow As Long
lastRow = Sht.Cells.SpecialCells(xlLastCell).Row
lRow = Sht.Cells.SpecialCells(xlLastCell).Row
Do While Application.CountA(Sht.Rows(lRow)) = 0 And lRow <> 1
lRow = lRow - 1
Loop
fn_LastRow = lRow
End Function
'In this example we are finding the last column of specified Sheet
Function fn_LastColumn(ByVal Sht As Worksheet)
Dim lastCol As Long
lastCol = Sht.Cells.SpecialCells(xlLastCell).Column
lCol = Sht.Cells.SpecialCells(xlLastCell).Column
Do While Application.CountA(Sht.Columns(lCol)) = 0 And lCol <> 1
lCol = lCol - 1
Loop
fn_LastColumn = lCol
End FunctionPost-16 Return First column if Second column has same Values else Second Column in Excel:
=IF(AND(F5=G5,F5=G5),F5,G5)
Post-15 Fill Interior color if it is matched with a particular String:Private Sub Worksheet_Change(ByVal Target As Range)
Set MyPlage = Range("B1:B50")
For Each Cell In MyPlage
Select Case Cell.Value
Case Is = "Withdrawn"
Cell.EntireRow.Interior.ColorIndex = 7
Case Is = "Postponed"
Cell.EntireRow.Interior.ColorIndex = 8
Case Is = "Terms Agreed"
Cell.EntireRow.Interior.ColorIndex = 4
Case Is = "Papers Rec"
Cell.EntireRow.Interior.ColorIndex = 3
Case Else
Cell.EntireRow.Interior.ColorIndex = xlNone
End Select
Next
End Sub
Post-15 Update Third column from second if First column has count more than 1:
UPDATE Table1 SET Table1.GTIN3 = GTIN2
WHERE (((Table1.[GTIN]) In (SELECT GTIN
FROM Table1
WHERE GTIN2 is not null and GTIN <> ""
GROUP BY GTIN
HAVING COUNT(*) > 1)));
Post-14 Generate an Excel report on same Project path:
Private Sub Command45_Click()
Dim Range As Object
Dim outputFileName As String
Dim db As DAO.Database
Set db = CurrentDb
outputFileName = CurrentProject.Path & "\Export_" & Format(Date, "yyyy-MM-dd") & ".xls"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "TblMatchedTb", outputFileName, True
End Sub
Post-13 Select string before the last special character:
select Left(dbo_temp_docdesc.DocName,InStrRev(dbo_temp_docdesc.DocName,'.')-1),dbo_temp_docdesc.DocName from dbo_temp_docdesc
Post-12 Convert data type into Number:
For Each c In Range("L2:L2000")
If c = "" Then GoTo Nextc
If IsNumeric(c) Then
c.Value = c.Value * 1
c.NumberFormat = "general"
End If
Nextc:
Next c
Post-11 Split rows into distinct rows :
Sub SplitCells()
'Update 20141024
Dim Rng As Range
Dim WorkRng As Range
On Error Resume Next
xTitleId = "KutoolsforExcel"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
For Each Rng In WorkRng
lLFs = VBA.Len(Rng) - VBA.Len(VBA.Replace(Rng, vbLf, ""))
If lLFs > 0 Then
Rng.Offset(1, 0).Resize(lLFs).Insert shift:=xlShiftDown
Rng.Resize(lLFs + 1).Value = Application.WorksheetFunction.Transpose(VBA.Split(Rng, vbLf))
End If
Next
End Sub
pass the range like
Post-10 Selected rows modification and color for it:
Range(ActiveSheet.Range("L2"), ActiveSheet.Range("L2").End(xlDown)).Select
Selection.Interior.ColorIndex = 43
For more about color :http://dmcritchie.mvps.org/excel/colors.htm
Sub TheWall() With ActiveSheet.UsedRange.Borders .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With ActiveSheet .Cells.Font.Size = "10" ActiveSheet.Cells.HorizontalAlignment = xlLeft End With Range("A1:P1").Select With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlBottom End With End SubPost-8 A specific Design with Example:-
1. If it is checked on AND button then output should cat and dog
2. If it is checked on OR button then output should cat or dog
3. While click on Category(Sub-Form) it will show like above scenario into down all text boxes.
Following code are usable for it ,paste this code inside the Search button:
Note : Table name is VERSION and sub form name is VERSIONs subform
Step-1
Private Sub Command6_Click()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Set db = CurrentDb()
Dim strFilterSQL As String
Dim strsearch As String
'strsearch = Me.Text0.Value
Dim strSQL As String
If IsNull(Me.Text0) Or Me.Text0 = "" Or Me.Text2 = "" Then
MsgBox "Please type in your search keyword.", vbOKOnly, "Keyword Needed"
Me.Text0.BackColor = vbYellow
Me.Text2.BackColor = vbYellow
Me.Text0.SetFocus
Else
'Const strSQL1 = "select code,Category from VERSION"
Select Case Frame1
'Filter record source dependant on option checked
Case 1
Me.[VERSIONs subform].Form.RecordSource = "select code,Category from VERSIONs Where ([Category] LIKE '*" & Me.Text0.Value & "*') and ([Category] LIKE '*" & Me.Text2.Value & "*')"
Case 2
Me.[VERSIONs subform].Form.RecordSource = "select code,Category from VERSIONs Where ([Category] LIKE '*" & Me.Text0.Value & "*') or ([Category] LIKE '*" & Me.Text2.Value & "*')"
End Select
Me.RecordSource = strFilterSQL
Me.Requery
Me.Text0.BackColor = vbGreen
Me.Text2.BackColor = vbGreen
' Me.[VERSIONs subform].Form.Filter = "[Category] LIKE '*" & Me.Text0.Value & "*'"
' Me.[VERSIONs subform].Form.FilterOn = True
' Me.[VERSIONs subform].Requery
End If
End Sub
paste this code inside the Category on click events
Step-2
Private Sub Category_Click()
Dim rst As DAO.Recordset
Dim strSQL As String
Dim seg As String
Dim segval As String
Dim Family As String
Dim Familyval As String
Dim clas As String
Dim clasval As String
Dim comm As String
Dim commval As String
' '===============Segment================
seg = CStr(Left(Me.Code, 2)) + "000000"
strSQL = "select Category from VERSIONs where code =" & seg & ""
Set rst = CurrentDb.OpenRecordset(strSQL)
segval = seg + " " + rst!Category
rst.Close
Set rst = Nothing
Forms![Form1].Text5.Value = segval
'===============Family======================
seg = CStr(Left(Me.Code, 4)) + "0000"
strSQL = "select Category from VERSIONs where code =" & seg & ""
Set rst = CurrentDb.OpenRecordset(strSQL)
segval = seg + " " + rst!Category
rst.Close
Set rst = Nothing
Forms![Form1].Text7.Value = segval
'==============Class========================
seg = CStr(Left(Me.Code, 6)) + "00"
strSQL = "select Category from VERSIONs where code =" & seg & ""
Set rst = CurrentDb.OpenRecordset(strSQL)
segval = seg + " " + rst!Category
rst.Close
Set rst = Nothing
Forms![Form1].Text9.Value = segval
'==============Commedity========================
seg = CStr(Left(Me.Code, 8))
strSQL = "select Category from VERSIONs where code =" & seg & ""
Set rst = CurrentDb.OpenRecordset(strSQL)
segval = seg + " " + rst!Category
rst.Close
Set rst = Nothing
Forms![Form1].Text11.Value = segval
End Sub
*********************************************************************************
Post-7 Export Access file to Excel format:-Private Sub Command45_Click()
Dim Range As Object
Dim outputFileName As String
Dim db As DAO.Database
Set db = CurrentDb
outputFileName = CurrentProject.Path & "\Export_" & Format(Date, "yyyy-MM-dd") & ".xls"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "TblMatchedTb", outputFileName, True
End Sub
*********************************************************************************
Post-6 Excel to MS Access converter:-Private Sub Command0_Click()
Dim strPathFile As String, strFile As String, strPath As String
Dim strTable As String
Dim blnHasFieldNames As Boolean
Const msoFileDialogFilePicker As Long = 3
Dim objDialog As Object
Set objDialog = Application.FileDialog(msoFileDialogFilePicker)
With objDialog
.AllowMultiSelect = False
.Show
If .SelectedItems.Count = 0 Then
MsgBox "!! No file selected.Please Select One !!"
Else
For Each vrtSelectedItem In .SelectedItems
Filename = vrtSelectedItem
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, "temp_input", Filename, True
' objDialog , FileName, blnHasFieldNames
Next
End If
End With
End Sub
*********************************************************************************
Post-5 Function to create auto Number in a table:-Function CreateAutoNumberField( _
ByVal strTableName As String, _
ByVal strFieldName As String) _
As Boolean
'References: Microsoft Access 11.0 Object Library, Microsoft DAO 3.6 Object Library
'Set references by Clicking Tools and Then References in the Code View window
'Creates an Autonumber field
'strTableName : Name of table in which to create the field
'strFieldName : Name of the new field
'Returns True on success, false otherwise
'USAGE: CreateAutoNumberField "TABLENAME", "FIELDNAME"
On Error GoTo errhandler
Dim Db As DAO.Database
Dim fld As DAO.Field
Dim tdf As DAO.TableDef
Set Db = Application.CurrentDb
Set tdf = Db.TableDefs(strTableName)
' First create a field with datatype = Long Integer
Set fld = tdf.CreateField(strFieldName, dbLong)
With fld
' Appending dbAutoIncrField to Attributes
' tells Jet that it's an Autonumber field
.Attributes = .Attributes Or dbAutoIncrField
End With
With tdf.Fields
.Append fld
.Refresh
End With
CreateAutoNumberField = True
ExitHere:
Set fld = Nothing
Set tdf = Nothing
Set Db = Nothing
'MsgBox "Autonumber Complete"
Exit Function
errhandler:
CreateAutoNumberField = False
With Err
MsgBox "Error " & .Number & vbCrLf & .Description, _
vbOKOnly Or vbCritical, "CreateAutonumberField"
End With
Resume ExitHere
End Function
Note:- after creating this function paste following code into your Button
Private Sub Command0_Click()
Dim Db As DAO.Database
Set Db = CurrentDb()
CreateAutoNumberField "Table1", "GH"
End Sub
*********************************************************************************Post-4 Update selected Combo box values in MS Access:-
'update table column and call the module function(removeSpecial)
Private Sub Command24_Click()
Dim db As DAO.Database
Set db = CurrentDb()
'If IsNull(Me.Combo20.Value) Or Me.Combo20.Value = " " Then
db.Execute "update [" + Me.Combo20.Value + "] set mfgid2=removeSpecial([mfgid])"
MsgBox "Table Column Updated"
End Sub*********************************************************************************
Post-3 Show all table in mdb into a combobox MS Access:-
Private Sub Command42_Click()
'Set db = CurrentDb()
Dim i As Integer
' ASSIGNING THE COMBO BOX COMBO3 TO NO DISPLAY
Combo20.RowSource = ""
' CLEARING THE COMBO BOX COMBO3
Combo20 = ""
Dim db As DAO.Database, tbl As TableDef, fld As Field
Set db = CurrentDb()
For Each tbl In db.TableDefs
If Left$(tbl.Name, 4) <> "MSys" And Mid(tbl.Name, 2, 4) <> "TMPC" Then
Combo20.AddItem tbl.Name
End If
Next tbl
End Sub
Note - If you want to refresh list after creating new table then paste this code again into new Command button.
*********************************************************************************
Post-2. MS - Access Functions:-
'Function for Revome SpeclChar
Function removeSpecial(sInput As String) As String
Dim sSpecialChars As String
Dim i As Long
sSpecialChars = "-&\/:*?""<>|@#"
For i = 1 To Len(sSpecialChars)
sInput = Replace$(sInput, Mid$(sSpecialChars, i, 1), "")
Next
removeSpecial = sInput
End Function
*********************************************************************************
'Function for calculating Variance of Two Columns in a Table
Function VarianceCalculate(sInput1 As Integer, sInput2 As Integer)
VarianceCalculate = ((sInput1 - sInput2) / sInput1 * 100)
If (VarianceCalculate) < 1 Then
VarianceCalculate = ((sInput2 - sInput1) / sInput2 * 100)
End If
End Function
*********************************************************************************
'Function to Delete a Table if allready Exist
Function TableExists(ByVal TableName As String) As Boolean
'*************************************************
' Purpose: Checks to see whether the named table exists in the database
'
' Returns: True, if table found in current db, False if not found.
'************************************************* ****************************
Dim strTableNameCheck
On Error GoTo ErrorCode
'try to assign tablename value
strTableNameCheck = CurrentDb.TableDefs(TableName)
'If no error and we get to this line, true
TableExists = True
ExitCode:
On Error Resume Next
Exit Function
ErrorCode:
Select Case Err.Number
Case 3265 'Item not found in this collection
TableExists = False
Resume ExitCode
Case Else
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "hlfUtils.TableExists"
'Debug.Print "Error " & Err.number & ": " & Err.Description & "hlfUtils.TableExists"
Resume ExitCode
End Select
End Function
*********************************************************************************
'Set db = CurrentDb()
Dim i As Integer
' ASSIGNING THE COMBO BOX COMBO3 TO NO DISPLAY
Combo20.RowSource = ""
' CLEARING THE COMBO BOX COMBO3
Combo20 = ""
Dim db As DAO.Database, tbl As TableDef, fld As Field
Set db = CurrentDb()
For Each tbl In db.TableDefs
If Left$(tbl.Name, 4) <> "MSys" And Mid(tbl.Name, 2, 4) <> "TMPC" Then
Combo20.AddItem tbl.Name
End If
Next tbl
End Sub
Note - If you want to refresh list after creating new table then paste this code again into new Command button.
*********************************************************************************
Post-2. MS - Access Functions:-
'Function for Revome SpeclChar
Function removeSpecial(sInput As String) As String
Dim sSpecialChars As String
Dim i As Long
sSpecialChars = "-&\/:*?""<>|@#"
For i = 1 To Len(sSpecialChars)
sInput = Replace$(sInput, Mid$(sSpecialChars, i, 1), "")
Next
removeSpecial = sInput
End Function
*********************************************************************************
'Function for calculating Variance of Two Columns in a Table
Function VarianceCalculate(sInput1 As Integer, sInput2 As Integer)
VarianceCalculate = ((sInput1 - sInput2) / sInput1 * 100)
If (VarianceCalculate) < 1 Then
VarianceCalculate = ((sInput2 - sInput1) / sInput2 * 100)
End If
End Function
*********************************************************************************
'Function to Delete a Table if allready Exist
Function TableExists(ByVal TableName As String) As Boolean
'*************************************************
' Purpose: Checks to see whether the named table exists in the database
'
' Returns: True, if table found in current db, False if not found.
'************************************************* ****************************
Dim strTableNameCheck
On Error GoTo ErrorCode
'try to assign tablename value
strTableNameCheck = CurrentDb.TableDefs(TableName)
'If no error and we get to this line, true
TableExists = True
ExitCode:
On Error Resume Next
Exit Function
ErrorCode:
Select Case Err.Number
Case 3265 'Item not found in this collection
TableExists = False
Resume ExitCode
Case Else
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "hlfUtils.TableExists"
'Debug.Print "Error " & Err.number & ": " & Err.Description & "hlfUtils.TableExists"
Resume ExitCode
End Select
End Function
*********************************************************************************
Post-1. Excel Macros:-
Delete First Rows in Single Sheet:
Sub sbVBS_To_Delete_EntireRow()
Rows(1).EntireRow.Delete
End Sub
---------------------
Delete First Rows for all sheets
Sub LoopThroughSheets()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Range("1:1").Delete
Next ws
End Sub
---------------------
Add Sheet Name in First column - in all Sheets
Sub Prepare_Sheet()
Dim WS As Worksheet
Dim LASTROW As Long
For Each WS In Sheets
With WS
LASTROW = .Range("A" & Rows.Count).End(xlUp).Row
.Columns(1).Insert
.Range("A1:A" & LASTROW) = WS.Name
End With
Next WS
End Sub
---------------------
add column Name
Sub Prepare_Sheet()
Dim WS As Worksheet
Dim LASTROW As Long
For Each WS In Sheets
With WS
.Range("A1") = "SheetName"
' LASTROW = .Range("A" & Rows.Count).End(xlUp).Row
' .Columns(1).Insert
' .Range("A1:A" & LASTROW) = WS.Name
End With
Next WS
End Sub
---------------------
---------------------
import to one sheet:
Sub CombineSheets()
Sub CombineSheets()
Dim ws As Worksheet, wsCombine As Worksheet
Dim rg As Range
Dim RowCombine As Integer
Set wsCombine = ThisWorkbook.Worksheets.Add(ThisWorkbook.Worksheets(1))
wsCombine.Name = "Combine"
RowCombine = 1
For Each ws In ThisWorkbook.Worksheets
If ws.Index <> 1 Then
Set rg = ws.Cells(1, 1).CurrentRegion
rg.Copy wsCombine.Cells(RowCombine, 2)
wsCombine.Range(Cells(RowCombine, 1), Cells(RowCombine + rg.Rows.Count - 1, 1)).NumberFormat = "@"
wsCombine.Range(Cells(RowCombine, 1), Cells(RowCombine + rg.Rows.Count - 1, 1)) = ws.Name
RowCombine = RowCombine + rg.Rows.Count
End If
Next
wsCombine.Cells(1, 1).EntireColumn.AutoFit
Set rg = Nothing
Set wsCombine = Nothing
End Sub
=============
Delete Empty Columns
Sub DeleteBlankColumns()
'Step1: Declare your variables.
Dim MyRange As Range
Dim iCounter As Long
'Step 2: Define the target Range.
Set MyRange = ActiveSheet.UsedRange
'Step 3: Start reverse looping through the range.
For iCounter = MyRange.Columns.Count To 1 Step -1
'Step 4: If entire column is empty then delete it.
If Application.CountA(Columns(iCounter).EntireColumn) = 0 Then
Columns(iCounter).Delete
End If
'Step 5: Increment the counter down
Next iCounter
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft
Columns("H:H").Select
Selection.Delete Shift:=xlToLeft
End Sub
=============
insert new column
Sub InsertColumns()
Sub InsertColumns()
'PURPOSE: Insert column(s) into the active worksheet
'SOURCE: www.TheSpreadsheetGuru.com
'Insert Column to the left of Column D
Columns("D:D").Insert Shift:=xlToRight, _
CopyOrigin:=xlFormatFromLeftOrAbove 'or xlFormatFromRightOrBelow
'Insert 2 Columns to the left of Column G
Columns("G:H").Insert Shift:=xlToRight, _
CopyOrigin:=xlFormatFromLeftOrAbove 'or xlFormatFromRightOrBelow
End Sub
===============
Select only filled row in excel (diagonally)
Sub Select_UsedRange()
Sub Select_UsedRange()
ActiveSheet.UsedRange.Select
End Sub
===============
merge all excel sheet into one
Sub simpleXlsMerger()
Dim bookList As Workbook
Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
Application.ScreenUpdating = False
Set mergeObj = CreateObject("Scripting.FileSystemObject")
'change folder path of excel files here
Set dirObj = mergeObj.Getfolder("D:\change\to\excel\files\path\here")
Set filesObj = dirObj.Files
For Each everyObj In filesObj
Set bookList = Workbooks.Open(everyObj)
'change "A2" with cell reference of start point for every files here
'for example "B3:IV" to merge all files start from columns B and rows 3
'If you're files using more than IV column, change it to the latest column
'Also change "A" column on "A65536" to the same column as start point
Range("A2:IV" & Range("A65536").End(xlUp).Row).Copy
ThisWorkbook.Worksheets(1).Activate
'Do not change the following column. It's not the same column as above
Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial
Application.CutCopyMode = False
bookList.Close
Next
End Sub
===============
===============
copy file name
Sub GetFileNames()
Sub GetFileNames()
Dim xRow As Long
Dim xDirect$, xFname$, InitialFoldr$
InitialFoldr$ = "C:\Users\mso\Desktop\2016 Periop Inventory Final_Done" '<<< Startup folder to begin searching from
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder to list Files from"
.InitialFileName = InitialFoldr$
.Show
If .SelectedItems.Count <> 0 Then
xDirect$ = .SelectedItems(1) & "\"
xFname$ = Dir(xDirect$, 7)
Do While xFname$ <> ""
ActiveCell.Offset(xRow) = xFname$
xRow = xRow + 1
xFname$ = Dir
Loop
End If
End With
End Sub
No comments:
Post a Comment