Sayre
07-01-2014, 02:25 PM
Hello! New to vbax.
I'm using the code originally posted by Kenneth Hobbs in thread # 46276. Reposting the code here per request of Kenneth Hobbs.
I'm new to this board but not new to vba although still pretty intermediate at best but I love researching and putting the assistance I get to good use. I have a large need for variations on import files macros which I never needed before. Excuuse the size of my request, please feel free to help on any little portion of it if you can, I appreciate anything I can get on this. This is great code to start with!
Here is Kenneth's code.
Part 1
' Windows folder and file details for windows versions and a VBA macro:
Sub FileDetails()
'SpeedOn
ListMyFiles ThisWorkbook.Path, Range("A2"), True, "Text Document"
ActiveSheet.UsedRange.Columns.AutoFit
Range("C:C").HorizontalAlignment = xlCenter
Range("F:H").HorizontalAlignment = xlCenter
Range("A1").Activate
'SpeedOff
End Sub
' Tools > References > Microsoft Scripting Runtime
' Tools > References > Microsoft Shell Controls and Automation
Sub ListMyFiles(mySourcePath As String, sRow As Range, _
Optional IncludeSubfolders As Boolean = True, Optional FileType As String = "")
Dim myObject As Scripting.FileSystemObject
Dim mySource As Scripting.Folder
Dim myFile As Scripting.File
Dim mySubFolder As Scripting.Folder
Dim wShell As Shell
Set wShell = New Shell
Set myObject = New Scripting.FileSystemObject
Set mySource = myObject.GetFolder(mySourcePath)
'On Error Resume Next
For Each myFile In mySource.Files
'If LCase(myFile.Path) = LCase(ThisWorkbook.Path) Then GoTo NextFile
If myFile.Type = FileType Or FileType = "" Then
With sRow
.Value2 = myFile.Path
.Offset(, 1).Value2 = myFile.Name
.Offset(, 2).Value2 = myFile.Size
.Offset(, 3).Value2 = myFile.Type
.Offset(, 4).Value2 = myFile.DateLastModified
.Offset(, 4).NumberFormat = "mm/dd/yyyy"
End With
With wShell.Namespace(mySource.Path)
'sRow.Offset(, 5).Value2 = .GetDetailsOf(.ParseName(myFile.Name), 151) 'Frame width Vista=265, Width=151 Win7.
'sRow.Offset(, 6).Value2 = .GetDetailsOf(.ParseName(myFile.Name), 153) 'Frame height Vista=263, Height=153 Win7.
'sRow.Offset(, 7).Value2 = .GetDetailsOf(.ParseName(myFile.Name), 36) 'Duration value, XP=21. 36 in Vista and Win7.
'srow.offset(, 8).Value2 = .GetDetailsOf(.ParseName(myFile.Name), 36) 'Duration word, XP=21. 36 in Vista and Win7.
End With
' Hyperlink
'sRow.Offset(, 8).Hyperlinks.Add sRow.Offset(, 8), myFile.Path, , , myObject.GetBaseName(myFile.Name)
Set sRow = sRow.Offset(1)
End If
NextFile:
Next
If IncludeSubfolders Then
For Each mySubFolder In mySource.SubFolders
ListMyFiles mySubFolder.Path, sRow, True, FileType
Next
End If
End Sub
[/vba]
This part works fine but I'd like it to be able to do .txt, .csv, etc... If I could list the types I want to search for in col A of 'mySheet' (partial value string *like* match starting row 2 through endup.xlrow) that would be great.
If not I can work with hard coding but I can't seem to figure out how to change this line of code:
[code]ListMyFiles ThisWorkbook.Path, Range("A2"), True, "Text Document"
so that it will search for not only "Text..." but also "comma separated...", or .out files, etc...
Here is part 2:
Sub Test_ImportTxtData()
Dim s1 As Worksheet, s2 As Worksheet
Dim c As Range, s1Range As Range, r As Range
Set s1 = Worksheets("Sheet1")
Set s1Range = s1.Range("A3:A" & s1.Range("A" & Rows.Count).End(xlUp).Row)
Set s2 = Worksheets("Sheet2")
Set r = s2.Range("A1")
Set c = s1.Range("A2")
' Import first txt file with header row.
ImportTxtData c.Value2, c.Offset(0, 1).Value2, s2, r, True
' Import others if needed.
If s1Range.Address(False, False) <> "A3" Then Exit Sub
For Each c In s1Range
Set r = s2.Range("A" & Rows.Count).End(xlUp).Offset(1)
ImportTxtData c.Value2, c.Offset(0, 1).Value2, s2, r
'Delete header row and mark first row added.
r.EntireRow.Delete shift:=xlUp
Rows(ActiveCell.Row).EntireRow.Font.Italic = True
Next c
End Sub
Sub ImportTxtData(sPath As String, sName As String, dSheet As Worksheet, _
dRange As Range, Optional tbFieldNames As Boolean = False)
Dim q As String, s As String
s = q & "TEXT;" & sPath & q
With dSheet.QueryTables.Add(s, dRange)
.Name = sName
.FieldNames = tbFieldNames
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 3, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End Sub
Would love this to be modified so it can import any file type in the list created from part 1, not just "TEXT;"
Also, would be great to be able to keep a list of partial list of values (col B of 'mySheet' strating row 2 through .endup xlrow) that the macro would run through the list on 'Sheet1', find the *like* partial string match, then import that entire file in 'Sheet2'.
I found this code that is close, but it only does one key word that must be hard coded into the script:
Sub ImportCSVsWithReference()
'Author: Jerry Beaucaire
'Date: 10/16/2010
'Summary: Import all CSV files from a folder into a single sheet
' adding a field in column A listing the CSV filenames
Dim wbCSV As Workbook
Dim wsMstr As Worksheet: Set wsMstr = ThisWorkbook.Sheets("sysinfo")
Dim fPath As String: fPath = "U:\Childerns_Hospital\Analysis Project\HNAS data\SMUDiagnostics\mgr\ExportedStats_20140506_093011_035" 'path to CSV files, include the final \
Dim fCSV As String
'If MsgBox("Clear the existing MasterCSV sheet before importing?", vbYesNo, "Clear?") _
= vbYes Then wsMstr.UsedRange.Clear
'Application.ScreenUpdating = False 'speed up macro
fCSV = Dir(fPath & "*.csv") 'start the CSV file listing
Do While Len(fCSV) > 0
'open a CSV file
Set wbCSV = Workbooks.Open(fPath & fCSV)
'insert col A and add CSV name
Columns(1).Insert xlShiftToRight
Columns(1).SpecialCells(xlBlanks).Value = ActiveSheet.Name
'copy date into master sheet and close source file
ActiveSheet.UsedRange.Copy wsMstr.Range("A" & Rows.Count).End(xlUp).Offset(1)
wbCSV.Close False
'ready next CSV
fCSV = Dir
Loop
Application.ScreenUpdating = True
End Sub
Sub testCSVimport()
'Dimension any other variables to your preference
Dim ResultArray(100000)
'Open the workbook with your list of acceptable data
Workbooks.Open Filename:="\\dfs\fs\users\Apollo\Apollo_5151308.0001_HDS_RACK.xlsx"
'Set LS to represent the path to the workbook with your list
Set LS = Workbooks("list.xlsx").Worksheets("Sheet1")
'open the csv file
Open "C:\Documents and Settings\Robert\My Documents\text.csv" For Input As #1
'begin to loop through the csv file line by line
Do While Not EOF(1)
Line Input #1, Data
'If your data is really consistent, then you can skip to the Mid to pull out the element _
you wish to compare, otherwise, you need to count commas until you have bracketed the element
datalength = Len(Data)
For a = 1 To datalength
If Mid(Data, a, 1) = "," Then
CommaCount = CommaCount + 1
If CommaCount = 2 Then MidStart = a + 1
If CommaCount = 3 Then
MidLng = a - MidStart
Exit For
End If
End If
Next a
'Use the data to extract the element you wish to compare
Element = Mid(Data, MidStart, MidLng)
'Use the Match function to compare your element to your list
On Error Resume Next
MatchVal = Application.WorksheetFunction.Match(CDbl(Element), LS.Range("A1:A5"), 0)
'If there is an error, then Err will not equal 0, so you can ignore that data. If Err = 0, then _
move the data into the ResultArray
If Err = 0 Then
ArrayCount = ArrayCount + 1
ResultArray(ArrayCount) = Data
End If
'Return CommaCount variable to 0
CommaCount = 0
Loop
'Close csv file and List file
Close #1
Workbooks("List.xlsx").Close
'I built this in a workbook, so I just dump the data. You can create a workbook from scratch
Worksheets("Sheet1").Activate
For b = 1 To ArrayCount
Cells(b, 1) = ResultArray(b)
Next b
'Here you have filtered data that you can use text to columns on
End Sub
This is a lot I know, any part of this that anyone can help with would be much appreciated!
I'm using the code originally posted by Kenneth Hobbs in thread # 46276. Reposting the code here per request of Kenneth Hobbs.
I'm new to this board but not new to vba although still pretty intermediate at best but I love researching and putting the assistance I get to good use. I have a large need for variations on import files macros which I never needed before. Excuuse the size of my request, please feel free to help on any little portion of it if you can, I appreciate anything I can get on this. This is great code to start with!
Here is Kenneth's code.
Part 1
' Windows folder and file details for windows versions and a VBA macro:
Sub FileDetails()
'SpeedOn
ListMyFiles ThisWorkbook.Path, Range("A2"), True, "Text Document"
ActiveSheet.UsedRange.Columns.AutoFit
Range("C:C").HorizontalAlignment = xlCenter
Range("F:H").HorizontalAlignment = xlCenter
Range("A1").Activate
'SpeedOff
End Sub
' Tools > References > Microsoft Scripting Runtime
' Tools > References > Microsoft Shell Controls and Automation
Sub ListMyFiles(mySourcePath As String, sRow As Range, _
Optional IncludeSubfolders As Boolean = True, Optional FileType As String = "")
Dim myObject As Scripting.FileSystemObject
Dim mySource As Scripting.Folder
Dim myFile As Scripting.File
Dim mySubFolder As Scripting.Folder
Dim wShell As Shell
Set wShell = New Shell
Set myObject = New Scripting.FileSystemObject
Set mySource = myObject.GetFolder(mySourcePath)
'On Error Resume Next
For Each myFile In mySource.Files
'If LCase(myFile.Path) = LCase(ThisWorkbook.Path) Then GoTo NextFile
If myFile.Type = FileType Or FileType = "" Then
With sRow
.Value2 = myFile.Path
.Offset(, 1).Value2 = myFile.Name
.Offset(, 2).Value2 = myFile.Size
.Offset(, 3).Value2 = myFile.Type
.Offset(, 4).Value2 = myFile.DateLastModified
.Offset(, 4).NumberFormat = "mm/dd/yyyy"
End With
With wShell.Namespace(mySource.Path)
'sRow.Offset(, 5).Value2 = .GetDetailsOf(.ParseName(myFile.Name), 151) 'Frame width Vista=265, Width=151 Win7.
'sRow.Offset(, 6).Value2 = .GetDetailsOf(.ParseName(myFile.Name), 153) 'Frame height Vista=263, Height=153 Win7.
'sRow.Offset(, 7).Value2 = .GetDetailsOf(.ParseName(myFile.Name), 36) 'Duration value, XP=21. 36 in Vista and Win7.
'srow.offset(, 8).Value2 = .GetDetailsOf(.ParseName(myFile.Name), 36) 'Duration word, XP=21. 36 in Vista and Win7.
End With
' Hyperlink
'sRow.Offset(, 8).Hyperlinks.Add sRow.Offset(, 8), myFile.Path, , , myObject.GetBaseName(myFile.Name)
Set sRow = sRow.Offset(1)
End If
NextFile:
Next
If IncludeSubfolders Then
For Each mySubFolder In mySource.SubFolders
ListMyFiles mySubFolder.Path, sRow, True, FileType
Next
End If
End Sub
[/vba]
This part works fine but I'd like it to be able to do .txt, .csv, etc... If I could list the types I want to search for in col A of 'mySheet' (partial value string *like* match starting row 2 through endup.xlrow) that would be great.
If not I can work with hard coding but I can't seem to figure out how to change this line of code:
[code]ListMyFiles ThisWorkbook.Path, Range("A2"), True, "Text Document"
so that it will search for not only "Text..." but also "comma separated...", or .out files, etc...
Here is part 2:
Sub Test_ImportTxtData()
Dim s1 As Worksheet, s2 As Worksheet
Dim c As Range, s1Range As Range, r As Range
Set s1 = Worksheets("Sheet1")
Set s1Range = s1.Range("A3:A" & s1.Range("A" & Rows.Count).End(xlUp).Row)
Set s2 = Worksheets("Sheet2")
Set r = s2.Range("A1")
Set c = s1.Range("A2")
' Import first txt file with header row.
ImportTxtData c.Value2, c.Offset(0, 1).Value2, s2, r, True
' Import others if needed.
If s1Range.Address(False, False) <> "A3" Then Exit Sub
For Each c In s1Range
Set r = s2.Range("A" & Rows.Count).End(xlUp).Offset(1)
ImportTxtData c.Value2, c.Offset(0, 1).Value2, s2, r
'Delete header row and mark first row added.
r.EntireRow.Delete shift:=xlUp
Rows(ActiveCell.Row).EntireRow.Font.Italic = True
Next c
End Sub
Sub ImportTxtData(sPath As String, sName As String, dSheet As Worksheet, _
dRange As Range, Optional tbFieldNames As Boolean = False)
Dim q As String, s As String
s = q & "TEXT;" & sPath & q
With dSheet.QueryTables.Add(s, dRange)
.Name = sName
.FieldNames = tbFieldNames
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 3, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End Sub
Would love this to be modified so it can import any file type in the list created from part 1, not just "TEXT;"
Also, would be great to be able to keep a list of partial list of values (col B of 'mySheet' strating row 2 through .endup xlrow) that the macro would run through the list on 'Sheet1', find the *like* partial string match, then import that entire file in 'Sheet2'.
I found this code that is close, but it only does one key word that must be hard coded into the script:
Sub ImportCSVsWithReference()
'Author: Jerry Beaucaire
'Date: 10/16/2010
'Summary: Import all CSV files from a folder into a single sheet
' adding a field in column A listing the CSV filenames
Dim wbCSV As Workbook
Dim wsMstr As Worksheet: Set wsMstr = ThisWorkbook.Sheets("sysinfo")
Dim fPath As String: fPath = "U:\Childerns_Hospital\Analysis Project\HNAS data\SMUDiagnostics\mgr\ExportedStats_20140506_093011_035" 'path to CSV files, include the final \
Dim fCSV As String
'If MsgBox("Clear the existing MasterCSV sheet before importing?", vbYesNo, "Clear?") _
= vbYes Then wsMstr.UsedRange.Clear
'Application.ScreenUpdating = False 'speed up macro
fCSV = Dir(fPath & "*.csv") 'start the CSV file listing
Do While Len(fCSV) > 0
'open a CSV file
Set wbCSV = Workbooks.Open(fPath & fCSV)
'insert col A and add CSV name
Columns(1).Insert xlShiftToRight
Columns(1).SpecialCells(xlBlanks).Value = ActiveSheet.Name
'copy date into master sheet and close source file
ActiveSheet.UsedRange.Copy wsMstr.Range("A" & Rows.Count).End(xlUp).Offset(1)
wbCSV.Close False
'ready next CSV
fCSV = Dir
Loop
Application.ScreenUpdating = True
End Sub
Sub testCSVimport()
'Dimension any other variables to your preference
Dim ResultArray(100000)
'Open the workbook with your list of acceptable data
Workbooks.Open Filename:="\\dfs\fs\users\Apollo\Apollo_5151308.0001_HDS_RACK.xlsx"
'Set LS to represent the path to the workbook with your list
Set LS = Workbooks("list.xlsx").Worksheets("Sheet1")
'open the csv file
Open "C:\Documents and Settings\Robert\My Documents\text.csv" For Input As #1
'begin to loop through the csv file line by line
Do While Not EOF(1)
Line Input #1, Data
'If your data is really consistent, then you can skip to the Mid to pull out the element _
you wish to compare, otherwise, you need to count commas until you have bracketed the element
datalength = Len(Data)
For a = 1 To datalength
If Mid(Data, a, 1) = "," Then
CommaCount = CommaCount + 1
If CommaCount = 2 Then MidStart = a + 1
If CommaCount = 3 Then
MidLng = a - MidStart
Exit For
End If
End If
Next a
'Use the data to extract the element you wish to compare
Element = Mid(Data, MidStart, MidLng)
'Use the Match function to compare your element to your list
On Error Resume Next
MatchVal = Application.WorksheetFunction.Match(CDbl(Element), LS.Range("A1:A5"), 0)
'If there is an error, then Err will not equal 0, so you can ignore that data. If Err = 0, then _
move the data into the ResultArray
If Err = 0 Then
ArrayCount = ArrayCount + 1
ResultArray(ArrayCount) = Data
End If
'Return CommaCount variable to 0
CommaCount = 0
Loop
'Close csv file and List file
Close #1
Workbooks("List.xlsx").Close
'I built this in a workbook, so I just dump the data. You can create a workbook from scratch
Worksheets("Sheet1").Activate
For b = 1 To ArrayCount
Cells(b, 1) = ResultArray(b)
Next b
'Here you have filtered data that you can use text to columns on
End Sub
This is a lot I know, any part of this that anyone can help with would be much appreciated!