Jlopez21887
New Member
- Joined
- Oct 31, 2016
- Messages
- 8
Currently I am looping through all files in a folder to grab certain columns based on the headers and pasting them all to a new master worksheet.
Currently I have a hyperlink being pasted at the end of each "section" by offsetting column B by .Range("B" & Rows.Count).End(xlUp).Offset(, 1) .
I would like to paste the filename to each record as well in Column C. That is being captured as Dim wbSource.
Any Help would be appreciated!
Currently I have a hyperlink being pasted at the end of each "section" by offsetting column B by .Range("B" & Rows.Count).End(xlUp).Offset(, 1) .
I would like to paste the filename to each record as well in Column C. That is being captured as Dim wbSource.
Code:
Option ExplicitConst pFolder = "FOLDER_PATH\"
Sub ImportAllData()
'Get Data from all Excel files in Event Response folder
Dim sFile As String 'file to open
Dim wsDestination As Worksheet
Dim wbSource As Workbook, wsSource As Worksheet
Dim hyperTarget As Long
Dim rngToCopy As Range, HeaderCell As Range
hyperTarget = 2 'Currently not in use
Application.ScreenUpdating = False
'confirm the pFolder (path) exists:
If Not FileFolderExists(pFolder) Then
MsgBox "Specified folder does not exist, Check folder path!"
Exit Sub
End If
'reset appl settings if error:
On Error GoTo errHandler 'disable this line while debugging.
'set the data destination worksheet:
Set wsDestination = Sheets(1)
'loop through the Excel files in the folder:
sFile = Dir(pFolder & "*.xls*")
Do Until sFile = ""
'open the source file and set the source worksheet:
Set wbSource = Workbooks.Open(pFolder & sFile)
Set wsSource = wbSource.ActiveSheet
'import the data from Active sheet in the Source WS:
With wsSource
'Look for value and copy column:
Set HeaderCell = Nothing
Set HeaderCell = .Rows(1).Find(what:="Project*", After:=Range("A1"), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchFormat:=False)
If HeaderCell Is Nothing Then
MsgBox "no Project column header found in sheet " & wsSource.Name & " of " & wbSource.Name
On Error GoTo errHandler
Else
Set rngToCopy = Range(HeaderCell.Offset(1), .Cells(.Rows.Count, HeaderCell.Column).End(xlUp))
With wsDestination
.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(rngToCopy.Rows.Count).Value = rngToCopy.Value
End With
End If
End With
With wsSource
'Look for value and copy column:
Set HeaderCell = Nothing
Set HeaderCell = .Rows(1).Find(what:="Ticket*", After:=Range("A1"), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchFormat:=False)
If HeaderCell Is Nothing Then
MsgBox "no Ticket column header found in sheet " & wsSource.Name & " of " & wbSource.Name
On Error GoTo errHandler
Else
Set rngToCopy = Range(HeaderCell.Offset(1), .Cells(.Rows.Count, HeaderCell.Column).End(xlUp))
With wsDestination
.Range("B" & Rows.Count).End(xlUp).Offset(1).Resize(rngToCopy.Rows.Count).Value = rngToCopy.Value
'Hyperlink to the source file:
.Hyperlinks.Add Anchor:=.Range("B" & Rows.Count).End(xlUp).Offset(, 1), Address:=(pFolder & sFile), TextToDisplay:="Link - " & sFile
End With
End If
End With
'Currently not in use as pasting the hyperlink to offset B.Row.Count(,1)
'close the source workbook, increment the hyperlink output row and get the next file:
wbSource.Close SaveChanges:=False
hyperTarget = hyperTarget + 1
sFile = Dir()
Loop
errHandler:
On Error Resume Next
Application.ScreenUpdating = True
'Clean up
Application.ScreenUpdating = True
Set wsSource = Nothing
Set wbSource = Nothing
Set wsDestination = Nothing
Set HeaderCell = Nothing
End Sub
Private Function FileFolderExists(strPath As String) As Boolean
If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True
End FunctionAny Help would be appreciated!
