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!
 

Some videos you may like

Excel Facts

Whats the difference between CONCAT and CONCATENATE?
The newer CONCAT function can reference a range of cells. =CONCATENATE(A1,A2,A3,A4,A5) becomes =CONCAT(A1:A5)

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,593
Office Version
  1. 2007
Platform
  1. Windows
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
 

Jlopez21887

New Member
Joined
Oct 31, 2016
Messages
8
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!
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,593
Office Version
  1. 2007
Platform
  1. Windows
I'm glad to help you. Thanks for the feedback.
 

Watch MrExcel Video

Forum statistics

Threads
1,109,538
Messages
5,529,431
Members
409,876
Latest member
Akash Yadav
Top