Why does this code not work with a named range? - excel

I'm a VBA newbie and did not write this code, credit goes to Ron de Bruin. I'm using it to retrieve the value from whichever cells I enter into the Range - line 12, from whichever files I select. It works with cell locations but all my files have different locations for the defined names. But when I put a defined name into the range, ie. Set rng = Range("cName1") it doesn't work. So basically how would I modify it so I can put a named range in (but also works with a cell location if possible...) Thank you in advance for any help!!
Sub Summary_cells_from_Different_Workbooks_1()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String
ShName = "Sheet1" '<---- Change
Set Rng = Range("D4:D20") '<---- Change
'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files, *.xl*", _
MultiSelect:=True)
If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)
'The links to the first workbook will start in row 2
RwNum = 1
For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)
'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName
'build the formula string
JustFileName = WorksheetFunction.Substitute(JustFileName, "'", "''")
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName & "'!"
On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(, , xlR1C1))
If Err.Number <> 0 Then
'If the sheet not exist in the workbook the row color will be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
.Interior.Color = vbYellow
Else
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = _
"=" & PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum
' Use AutoFit to set the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit
MsgBox "The Summary is ready, save the file if you want to keep it"
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub

Related

The file name of the excel workbooks the Macro pulls data from to be recorded

I would want the file names to be recorded in the "MasterFile" next to the data pulled from the respective files, so that i can map data items to the file names.
Any guidance/ ideas are much appreciated!! Thanks in advance :)
Code:
Sub PIDataExtraction()
Dim myFile As String, Path As String
Dim erow As Long, col As Long
Dim shtSrc As Worksheet
Dim copyrange As Range, cel As Range
fpath = Range("B2").Value
myFile = Dir(Path & "*.xl??")
Application.ScreenUpdating = False
Do While myFile <> ""
Workbooks.Open (Path & myFile)
Windows(myFile).Activate
On Error Resume Next
Set shtSrc = Worksheets("RX Ratings Price Calculator")
If err = 9 Then
On Error Resume Next
Set shtSrc = Worksheets("Feed Content Pricing Guideline")
If err = 9 Then Exit Sub
On Error GoTo 0
End If
Set copyrange = shtSrc.Range("B4,E7,E9,E11,E13,E15,Ratings_Universe_Default,J22,C24,C25,C26,I11,R16")
Windows("MasterFile.xlsm").Activate
erow = Data.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
col = 1
For Each cel In copyrange
Cells(erow, col).Value = cel.Value
col = col + 1
Next
Windows(myFile).Close savechanges:=False
myFile = Dir()
Loop
Range("A:E").EntireColumn.AutoFit
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Data has been Compiled,Please Check!"
End Sub

Excel error message"one or more named invalid references"

I cannot find the named range or reference that is invalid, according to Excel. I checked my named ranges, including ranges within charts. The excel file contains a macro that creates a report that works fine when launched within the file itself. However, if I call that function from another workbook to run the report that is when I get the error message of invalid references. When going through the reports created both directly and indirectly they seem identical. Setting Application.DisplayAlerts = False does not work.
I tried using the code below from from Allen Wyatt to go through all reference and none refer to outside sheets nor contain any errors.
Sub CheckReferences()
' Check for possible missing or erroneous links in
' formulas and list possible errors in a summary sheet
Dim iSh As Integer
Dim sShName As String
Dim sht As Worksheet
Dim c, sChar As String
Dim rng As Range
Dim i As Integer, j As Integer
Dim wks As Worksheet
Dim sChr As String, addr As String
Dim sFormula As String, scVal As String
Dim lNewRow As Long
Dim vHeaders
vHeaders = Array("Sheet Name", "Cell", "Cell Value", "Formula")
'check if 'Summary' worksheet is in workbook
'and if so, delete it
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
End With
For i = 1 To Worksheets.Count
If Worksheets(i).Name = "Summary" Then
Worksheets(i).Delete
End If
Next i
iSh = Worksheets.Count
'create a new summary sheet
Sheets.Add After:=Sheets(iSh)
Sheets(Sheets.Count).Name = "Summary"
With Sheets("Summary")
Range("A1:D1") = vHeaders
End With
lNewRow = 2
' this will not work if the sheet is protected,
' assume that sheet should not be changed; so ignore it
On Error Resume Next
For i = 1 To iSh
sShName = Worksheets(i).Name
Application.Goto Sheets(sShName).Cells(1, 1)
Set rng = Cells.SpecialCells(xlCellTypeFormulas, 23)
For Each c In rng
addr = c.Address
sFormula = c.Formula
scVal = c.Text
For j = 1 To Len(c.Formula)
sChr = Mid(c.Formula, j, 1)
If sChr = "[" Or sChr = "!" Or _
IsError(c) Then
'write values to summary sheet
With Sheets("Summary")
.Cells(lNewRow, 1) = sShName
.Cells(lNewRow, 2) = addr
.Cells(lNewRow, 3) = scVal
.Cells(lNewRow, 4) = "'" & sFormula
End With
lNewRow = lNewRow + 1
Exit For
End If
Next j
Next c
Next i
' housekeeping
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
End With
' tidy up
Sheets("Summary").Select
Columns("A:D").EntireColumn.AutoFit
Range("A1:D1").Font.Bold = True
Range("A2").Select
End Sub

VBA - Loop through files in a folder AND copy single cells as well as a range, if condition is met

I am currently using a piece of code to loop through files in a folder and copy certain cells from each file into a master list. There are a number of files being added into the folder every week. One of the columns in the master list includes the filenames of previously looped files. The code only loops through files that are not included in the filename list and therefore also have not previously been looped.
The code works really well and copies cells with satisfactory results however I now need to modify it to also copy a range of data (A20:H33 specifically) as well as meeting the above condition of not already being looped.
I have tried the following unsuccesfully:
Adding another varTemp to the code (As seen in the main code)
Adding a sub that can copy a range (However I have been unable to incorporate this into the code so it satisfies the not looped condition)
Using selection.copy and selection.paste however an error that I cannot workaround pops up ("Object doesn't support this property or method")
Here is the main code:
Option Explicit
Sub CopyFromFolderExample()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1)
Dim strFolder As String, strFile As String, r As Long, wb As Workbook
Dim varTemp(1 To 6) As Variant
Application.ScreenUpdating = False
strFolder = "D:\Other\folder\"
r = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
strFile = Dir(strFolder & "*.xl*")
Do While Len(strFile) > 0
If Not Looped(strFile, ws) Then
Application.StatusBar = "Reading data from " & strFile & "..."
Set wb = Workbooks.Add(strFolder & strFile)
With wb.Worksheets(1)
varTemp(1) = strFile
varTemp(2) = .Range("A13").Value
varTemp(3) = .Range("H8").Value
varTemp(4) = .Range("H9").Value
varTemp(5) = .Range("H37").Value
'varTemp(6) = .Range("A20:H33").Value
End With
wb.Close False
r = r + 1
ws.Range(ws.Cells(r, 1), ws.Cells(r, 6)).Formula = varTemp
End If
strFile = Dir
Loop
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
Private Function Looped(strFile As String, ws As Worksheet) As Boolean
Dim Found As Range
Set Found = ws.Range("A:A").Find(strFile)
If Found Is Nothing Then
Looped = False
Else
Looped = True
End If
End Function
This is the snippet of code that when inserted into the main code just below tha last vartemp gives me the following error ("Object doesn't support this property or method")
.Range("A20:H33").Select
.Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
ws.Activate
If ws.Range("A1") = "" Then
ws.Range("A1").Select
Selection.Paste
Else
Selection.End(xlDown).Offset(6, 0).Select
Selection.Paste
End If
Here is what I am trying to achieve:
I think that if you use a Range variable instead of a Variant to copy and paste the Range(A20:AH33) should get the job done.
Declare:
Dim rg as Range
Then replace this line of code:
varTemp(6) = .Range("A20:H33").Value
For this:
Set rg = .Range("A20:H33")
Then you can just Rg.Copy and paste whereaver you want.
Don't forget to "clear" the copybuffer after you paste the information:
Application.CutCopyMode = False
Avoid to use Selectionand Activate in your code, the reasons for it can be seen here:
How to avoid using Select in Excel VBA
and here:
https://www.businessprogrammer.com/power-excel-vba-secret-avoid-using-select/
This should do it. I've turned your array back to 5 elements, and the range is transferred separately. I've added a few new variables which you might want to give more meaningful names.
Sub CopyFromFolderExample()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1)
Dim strFolder As String, strFile As String, r As Long, wb As Workbook
Dim varTemp(1 To 5) As Variant, r1 As Long, r3 As Range
Application.ScreenUpdating = False
strFolder = "D:\Other\folder\"
strFile = Dir(strFolder & "*.xl*")
Do While Len(strFile) > 0
If Not Looped(strFile, ws) Then
Application.StatusBar = "Reading data from " & strFile & "..."
Set wb = Workbooks.Add(strFolder & strFile)
With wb.Worksheets(1)
varTemp(1) = strFile
varTemp(2) = .Range("A13").Value
varTemp(3) = .Range("H8").Value
varTemp(4) = .Range("H9").Value
varTemp(5) = .Range("H37").Value
Set r3 = .Range("A20:H33")
End With
With ws
r = .Range("A" & .Rows.Count).End(xlUp).Row + 1
r1 = .Range("F" & .Rows.Count).End(xlUp).Row + 1 'last used row in col F
.Range(.Cells(r, 1), .Cells(r, 5)).Value = varTemp
.Cells(r1, 6).Resize(r3.Rows.Count, r3.Columns.Count).Value = r3.Value 'transfer A20:H33
End With
wb.Close False
End If
strFile = Dir
Loop
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub

VBA Compare 2 sheets, move old comments to new sheet

Basically i have this script which compare 2 sheets, which compares a value in a column to the new sheet, if it finds the value, it will copy the information from Old sheet "B" to new sheet "B" column.
The script is working flawlessly (Thanks to the author)
I have trying to configure it to search and compare not only 1 column, but 2, if column X AND Y are equal to X AND Y in the new sheet it will do the same task.
The reason for this is that sometimes i have the value it searches for in few different rows, so when it compares it will find it at few places. While this script works perfect only when there are unique "Find" values.
Can you help me to edit so it fits "Find" and compare Column "P" & Column "V" if those are the same in new sheet, it will copy the Values in Column "B" old sheet to "B" new sheet.
Sub movecommentsInternode()
Dim Wb As Workbook
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim rSourcePCol As Range
Dim rSourcePCell As Range
Dim rDestPCol As Range
Dim rFound As Range
Dim sFirst As String
Dim sNotFound As String
Set Wb = ActiveWorkbook
Set wsSource = Wb.Sheets("Internode Buffer")
Set wsDest = Wb.Sheets("DataInternode")
Set rSourcePCol = wsSource.Range("P2", wsSource.Cells(wsSource.Rows.Count, "P").End(xlUp))
Set rDestPCol = wsDest.Range("P2", wsDest.Cells(wsDest.Rows.Count, "P").End(xlUp))
If rSourcePCol.row < 2 Then
MsgBox "No comment available, therefor no import is needed " ' & wsSource.Name
Exit Sub
ElseIf rDestPCol.row < 2 Then
MsgBox "Data Sheet is empty, please import the correct IO-List to be able to merge the comments " ' & wsDest.Name
Exit Sub
End If
For Each rSourcePCell In rSourcePCol.Cells
Set rFound = rDestPCol.Find(rSourcePCell.Value, rDestPCol.Cells(rDestPCol.Cells.Count), xlValues, xlWhole)
If rFound Is Nothing Then
sNotFound = sNotFound & Chr(10) & rSourcePCell.Value
Else
sFirst = rFound.Address
Do
rFound.Offset(, -14).Value = rSourcePCell.Offset(, -14).Value
Set rFound = rDestPCol.FindNext(rFound)
Loop While rFound.Address <> sFirst
End If
Next rSourcePCell
If Len(sNotFound) = 0 Then
MsgBox ("Import completed" & vbCrLf & "All comments have been merged with the new imported IO-List")
Else
MsgBox ("Import completed" & vbCrLf & "The following tag-comments have not been merged with new IO-List:" & sNotFound)
End If
End Sub
Also as a extra thing: Can you help me make it show the missing tags in a list (New sheet) insted of as comment. Will be ackward if there is hundreds of missing tags showing all in Msgbox.
Give this a try:
Sub movecommentsInternode()
Dim Wb As Workbook
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim wsMissingTags As Worksheet
Dim rSourcePCol As Range
Dim rSourcePCell As Range
Dim rDestPCol As Range
Dim rFound As Range
Dim sFirst As String
Dim sNotFound As String
Dim bFound As Boolean
Dim aHeaders() As Variant
Dim aMissingTags As Variant
Set Wb = ActiveWorkbook
Set wsSource = Wb.Sheets("Internode Buffer")
Set wsDest = Wb.Sheets("DataInternode")
Set rSourcePCol = wsSource.Range("P2", wsSource.Cells(wsSource.Rows.Count, "P").End(xlUp))
Set rDestPCol = wsDest.Range("P2", wsDest.Cells(wsDest.Rows.Count, "P").End(xlUp))
If rSourcePCol.Row < 2 Then
MsgBox "No comment available, therefor no import is needed " ' & wsSource.Name
Exit Sub
ElseIf rDestPCol.Row < 2 Then
MsgBox "Data Sheet is empty, please import the correct IO-List to be able to merge the comments " ' & wsDest.Name
Exit Sub
End If
For Each rSourcePCell In rSourcePCol.Cells
bFound = False
Set rFound = rDestPCol.Find(rSourcePCell.Value, rDestPCol.Cells(rDestPCol.Cells.Count), xlValues, xlWhole)
If Not rFound Is Nothing Then
sFirst = rFound.Address
Do
If rSourcePCell.Offset(, 6).Value = rFound.Offset(, 6).Value Then
rFound.Offset(, -14).Value = rSourcePCell.Offset(, -14).Value
bFound = True
End If
If bFound = True Then Exit Do 'First match for both columns found, exit find loop (this line can be removed if preferred)
Set rFound = rDestPCol.FindNext(rFound)
Loop While rFound.Address <> sFirst
End If
If bFound = False Then sNotFound = sNotFound & "|" & rSourcePCell.Value & vbTab & rSourcePCell.Offset(, 6).Value
Next rSourcePCell
If Len(sNotFound) = 0 Then
MsgBox ("Import completed" & vbCrLf & "All comments have been merged with the new imported IO-List")
Else
On Error Resume Next
Set wsMissingTags = Wb.Worksheets("Missing Tags")
On Error GoTo 0
If wsMissingTags Is Nothing Then
'Missing Tags worksheet doesn't exist, create it and add headers
aHeaders = Array(wsSource.Range("P1").Value, wsSource.Range("V1").Value)
Set wsMissingTags = Wb.Worksheets.Add(After:=Wb.Worksheets(Wb.Worksheets.Count))
wsMissingTags.Name = "Missing Tags"
With wsMissingTags.Range("A1").Resize(, UBound(aHeaders) - LBound(aHeaders) + 1)
.Value = aHeaders
.Font.Bold = True
.Borders(xlEdgeBottom).LineStyle = xlContinuous
End With
Else
'Missing Tags worksheet already exists, clear previous contents (if any)
wsMissingTags.Range("A1").CurrentRegion.Offset(1).ClearContents
End If
aMissingTags = Split(Mid(sNotFound, 2), "|")
With wsMissingTags.Range("A2").Resize(UBound(aMissingTags) - LBound(aMissingTags) + 1)
.Value = Application.Transpose(aMissingTags)
.TextToColumns .Cells, xlDelimited, Tab:=True
End With
MsgBox "Import completed" & vbCrLf & "See the Missing Tags worksheet for a list of tag-comments that have not been merged with new IO-List."
End If
End Sub
It is a fine code. I modified and tried it and find working as per my understanding of your requirement The modified full code is:
Sub movecommentsInternode()
Dim Wb As Workbook
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim rSourceHCol As Range
Dim rDestHCol As Range
Dim rdestHCell As Range
Dim rSourceHCell As Range
Dim rSourceHCol2 As Range 'added
Dim rDestHCol2 As Range 'added
Dim rSourceHCell2 As Range 'added
Dim rdestHCell2 As Range 'added
Dim rFound As Range
Dim sFirst As String
Dim sNotFound As String
Set Wb = ActiveWorkbook
Set wsSource = Wb.Sheets("Internode Buffer")
Set wsDest = Wb.Sheets("DataInternode")
Set rSourceHCol = wsSource.Range("H2", wsSource.Cells(wsSource.Rows.Count, "H").End(xlUp))
Set rDestHCol = wsDest.Range("H2", wsDest.Cells(wsDest.Rows.Count, "H").End(xlUp))
'Next two lines added
Set rSourceHCol2 = wsSource.Range("V2", wsSource.Cells(wsSource.Rows.Count, "V").End(xlUp))
Set rDestHCol2 = wsDest.Range("V2", wsDest.Cells(wsDest.Rows.Count, "V").End(xlUp))
If rSourceHCol.Row < 2 Or rSourceHCol2.Row < 2 Then ' condition modified
MsgBox "No comment available, therefor no import is needed " ' & wsSource.Name
Exit Sub
ElseIf rDestHCol.Row < 2 Or rDestHCol2.Row < 2 Then ' condition modified
MsgBox "Data Sheet is empty, please import the correct IO-List to be able to merge the comments " ' & wsDest.Name
Exit Sub
End If
For Each rSourceHCell In rSourceHCol.Cells
Set rSourceHCell2 = rSourceHCell.Offset(0, 14) 'corresponding value in V Col Source Sheet
Set rFound = rDestHCol.Find(rSourceHCell.Value, rDestHCol.Cells(rDestHCol.Cells.Count), xlValues, xlWhole)
If rFound Is Nothing Then
sNotFound = sNotFound & Chr(10) & rSourceHCell.Value
Else
sFirst = rFound.Address
Do
'Next two lines and if clause added
Set rdestHCell2 = rFound.Offset(0, 14) 'corresponding value in V Col Destination Sheet
If rSourceHCell2.Value = rdestHCell2.Value Then ' added
rFound.Offset(0, -6).Value = rSourceHCell.Offset(0, -6).Value 'offset from H to B
End If
Set rFound = rDestHCol.FindNext(rFound)
Loop While rFound.Address <> sFirst
End If
Next rSourceHCell
If Len(sNotFound) = 0 Then
MsgBox ("Import completed" & vbCrLf & "All comments have been merged with the new imported IO-List")
Else
MsgBox ("Import completed" & vbCrLf & "The following tag-comments have not been merged with new IO-List:" & sNotFound)
End If
End Sub
Edit: line Set rSourceHCell2 = rSourceHCell.Offset(0, 14) moved after line For Each rSourceHCell In rSourceHCol.Cells . If it does not work try to use If StrComp(rSourceHCell2.Value, rDestHCell2.Value) = 0 Then in place of If rSourceHCell2.Value = rdestHCell2.Value Then

Combine CSV files with Excel VBA

I have some csv files in one folder. They all contain 3 specific columns. The number of total columns and the order may vary.
I want to concatenate all 3 columns with an underscore and write them in a single column in the worksheet that is running the code.
Here is what I have so far:
Option Explicit
Sub test()
Dim i As Long
Dim LastRow As Long
Dim Columns()
Columns = Array("Column1", "Column2", "Column3")
'Find Columns by Name
For i = 0 To 2
Columns(i) = Rows(1).Find(What:=Columns(i), LookIn:=xlValues, LookAt:=xlWhole, _
MatchCase:=False, SearchFormat:=False).Column
Next i
'Debug.Print Columns(0)
'Debug.Print Columns(1)
'Debug.Print Columns(2)
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
Cells(i, 1) = Cells(i, Columns(0)) & "_" & Cells(i, Columns(1)) & "_" & Cells(i, Columns(2))
Next i
End Sub
As you can see, this does what I want, but only for the active sheet.
I actually want to loop through all csv files in the same folder as the active sheet and write the results in the first sheet, first column of the sheet running the code (which is not a csv itself obviously).
How can I do this?
thanks!
This is a code that will loop through a folder
Sub Button1_Click()
Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
Set Wb = ThisWorkbook
'change the address to suite
MyDir = "C:\WorkBookLoop\"
MyFile = Dir(MyDir & "*.xls") 'change file extension
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0
Do While MyFile <> ""
Workbooks.Open (MyFile)
'do something here
MyFile = Dir()
Loop
End Sub
It depends how you are naming the worksheets you create from the CSV files. You could add all the worksheets to a collection and use a For...Each loop to execute the entire search and concatenate procedure within that loop. Note that you'd have to explicitly define the first sheet name as this won't change through successive loops:
Option Explicit
Sub test()
Dim i As Long
Dim LastRow As Long
Dim Columns()
Dim frontSheet as Worksheet
Dim wSheets as New Collection
Dim ws as Worksheet
Set frontSheet = Sheets("name of front sheet")
'Add all your CSV sheets to wSheets using the .Add() method.
For Each ws in wSheets
Columns = Array("Column1", "Column2", "Column3")
'Find Columns by Name
For i = 0 To 2
Columns(i) = ws.Rows(1).Find(What:=Columns(i), LookIn:=xlValues, LookAt:=xlWhole, _
MatchCase:=False, SearchFormat:=False).Column
Next i
'Debug.Print Columns(0)
'Debug.Print Columns(1)
'Debug.Print Columns(2)
LastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
frontsheet.Cells(i, 1) = ws.Cells(i, Columns(0)) & "_" & ws.Cells(i, Columns(1)) & "_" & ws.Cells(i, Columns(2))
Next i
Next ws
End Sub
It's often slow and labourious to open CSV files in excel but VBA can read them as text files using a TextStream. Furthermore, file scripting objects let you work with files and directories directly. Something like this might be a better approach if you don't need to keep the files in a worksheet afterwards:
Sub SearchFoldersForCSV()
Dim fso As Object
Dim fld As Object
Dim file As Object
Dim ts As Object
Dim strPath As String
Dim lineNumber As Integer
Dim lineArray() As String
Dim cols() As Integer
Dim i As Integer
Dim frontSheet As Worksheet
Dim frontSheetRow As Integer
Dim concatString As String
Set frontSheet = Sheets("name of front sheet")
frontSheetRow = 1
strPath = "C:\where-im-searching\"
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(strPath)
For Each file In fld.Files
If (Right(file.Name, 3) = "csv") Then
Debug.Print file.Name
Set ts = file.OpenAsTextStream()
lineNumber = 0
Do While Not ts.AtEndOfStream
lineNumber = lineNumber + 1
lineArray = Split(ts.ReadLine, ",")
If (lineNumber = 1) Then
'We are at the first line of the .CSV so
'find index in lineArray of columns of interest
'Add extra ElseIf as required
For i = LBound(lineArray) To UBound(lineArray)
If lineArray(i) = "Column 1" Then
cols(1) = i
ElseIf lineArray(i) = "Column 2" Then
cols(2) = i
ElseIf lineArray(i) = "Column 3" Then
cols(3) = i
End If
Next i
Else
'Read and store the column of interest from this
'row by reading the lineArray indices found above.
concatString = ""
For i = LBound(cols) To UBound(cols)
concatString = concatString & lineArray(i) & "_"
Next i
concatString = Left(concatString, Len(concatString) - 1)
frontSheet.Cells(frontSheetRow, 1).Value = concatString
frontSheetRow = frontSheetRow + 1
End If
Loop
ts.Close
End If
Next file
End Sub
You can find more information on FileSystemObject and TextStream here.

Resources