Paste Filename to Range - VBA

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.


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 Function

Any Help would be appreciated!
 

Excel Facts

Using Function Arguments with nested formulas
If writing INDEX in Func. Arguments, type MATCH(. Use the mouse to click inside MATCH in the formula bar. Dialog switches to MATCH.
Try this
The changes I marked in blue

Code:
Option Explicit
'Const pFolder = "FOLDER_PATH\"
Const pFolder = "C:\trabajo\books\"




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
[COLOR=#0000ff] Dim lr As Long[/COLOR]
 
 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
[COLOR=#0000ff]        lr = .Range("A" & Rows.Count).End(xlUp).Offset(1).Row[/COLOR]
[COLOR=#0000ff]        .Range("A" & lr).Resize(rngToCopy.Rows.Count).Value = rngToCopy.Value[/COLOR]
[COLOR=#0000ff]        .Range("C" & lr).Resize(rngToCopy.Rows.Count).Value = sFile[/COLOR]
      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
[COLOR=#0000ff]        .Range("B" & lr).Resize(rngToCopy.Rows.Count).Value = rngToCopy.Value[/COLOR]
[COLOR=#0000ff]        'Hyperlink to the source file:[/COLOR]
[COLOR=#0000ff]        '.Hyperlinks.Add Anchor:=.Range("B" & Rows.Count).End(xlUp).Offset(, 1), Address:=(pFolder & sFile), TextToDisplay:="Link - " & sFile[/COLOR]
[COLOR=#0000ff]        .Hyperlinks.Add Anchor:=.Range("C" & lr).Resize(rngToCopy.Rows.Count), Address:=(pFolder & sFile), TextToDisplay:="Link - " & sFile[/COLOR]
      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 Function
 
Upvote 0
Try this
The changes I marked in blue

Code:
Option Explicit
'Const pFolder = "FOLDER_PATH\"
Const pFolder = "C:\trabajo\books\"




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
[COLOR=#0000ff] Dim lr As Long[/COLOR]
 
 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
[COLOR=#0000ff]        lr = .Range("A" & Rows.Count).End(xlUp).Offset(1).Row[/COLOR]
[COLOR=#0000ff]        .Range("A" & lr).Resize(rngToCopy.Rows.Count).Value = rngToCopy.Value[/COLOR]
[COLOR=#0000ff]        .Range("C" & lr).Resize(rngToCopy.Rows.Count).Value = sFile[/COLOR]
      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
[COLOR=#0000ff]        .Range("B" & lr).Resize(rngToCopy.Rows.Count).Value = rngToCopy.Value[/COLOR]
[COLOR=#0000ff]        'Hyperlink to the source file:[/COLOR]
[COLOR=#0000ff]        '.Hyperlinks.Add Anchor:=.Range("B" & Rows.Count).End(xlUp).Offset(, 1), Address:=(pFolder & sFile), TextToDisplay:="Link - " & sFile[/COLOR]
[COLOR=#0000ff]        .Hyperlinks.Add Anchor:=.Range("C" & lr).Resize(rngToCopy.Rows.Count), Address:=(pFolder & sFile), TextToDisplay:="Link - " & sFile[/COLOR]
      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 Function


This worked! Thank you so much!
I don't know why I was trying to use wbSource in the first place and not sFile!

Appreciate all the help!
 
Upvote 0

Forum statistics

Threads
1,223,164
Messages
6,170,444
Members
452,326
Latest member
johnshaji

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top