Look up value and copy variable coulmn

[ImThatGuy]

Hi all, I am new to this forum.

I have a project I am working on where I get sent about 25-30 files a week that I currently only need one column out of. I need to search for a key phrase "Supervisor" that is used as a column heading. The issue is what column that header in varies from file to file Typical Range from A1:BA1. I then need to copy that entire column (Minus header) and past it to a new workbook in the next available row in column A.

I have written so many variations of this but with no luck :bug:. Currently I get to opening the source file it copies the data and then the code stops and nothing else happens. I have bolded and underlined the comment the code block that I am having trouble with. When I comment that code block out the code runs as it should and loops through all the files.

Thank you in advance for any help!!



Option ExplicitConst pFolder = "xxxxx" ' I needed to remove the folder path for security purposes.




Sub ImportColumnData()


'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
Dim wsSource As Worksheet
Dim aCells As Range
Dim rowTarget As Long 'output row
Dim hyperTarget As Long


hyperTarget = 2
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
Application.ScreenUpdating = False

'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 to the wsDestination from Active sheet in the wsSource (Code block with issue)
With wsSource
'Look for value and copy column
Cells.Find(What:="Supervisor", After:=Range("A1"), _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows).EntireColumn.Copy

'Select Destination WS, column A and paste
wsDestination.Select
Range("A2").Select
ActiveSheet.Paste
Application.CutCopyMode = False

End With



'Hyperlink to the source file
With wsDestination
.Hyperlinks.Add Anchor:=.Range("L" & hyperTarget), _
Address:=(pFolder & sFile), _
TextToDisplay:="Link - " & sFile
End With

'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
Set wsSource = Nothing
Set wbSource = Nothing
Set wsDestination = Nothing
Application.ScreenUpdating = True
End Sub








Private Function FileFolderExists(strPath As String) As Boolean
If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True
End Function

[werafa]

Two questions.

what happens when you get rid of the 'with' statement (write the code in 'long-hand')?

what do you get if you set the cells.find range to an object?


dim myRange as range
myrange = cells.find.........

this will tell you if the problem is in the range identification or the range copy operation

you should also be able to use 'range.copy [destination]' to copy and paste in a single operation - and also remove all of the destination select code

[werafa]

Another question, what range are you searching for the 'Supervisor' string?

try With wsSource.Range("A:A")

[p45cal]

Difficult to work blind, but try this snippet instead of you errant code block to help debug problem:
Set Destn = wsDestination.Range("A1") 'note that it's A1 and not A2 since an entire column won't fit if you paste it to A2.
With wsSource
'Look for value and copy column
Set SupervisorCell = Nothing
'note the added dot before Cells in the next line.
Set SupervisorCell = .Cells.Find(What:="Supervisor", After:=Range("A1"), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows).EntireColumn.Copy
If SupervisorCell Is Nothing Then
MsgBox "no Supervisor found in sheet " & wsSource.Name & " of " & wbSource.Name
Else
Application.Goto SupervisorCell
MsgBox "Selected cell found - check it's what you expect."
'Select Destination WS, column A and paste
SupervisorCell.EntireColumn.Copy Destn
Set Destn = Destn.Offset(, 1) 'move the destination to the next column.
End If
End With


If you're using a PC (not a Mac) then it could also be safer to add SearchFormat:=False to the:
Set SupervisorCell = .Cells.Find(What:="Supervisor", After:=Range("A1"), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchFormat:=False).EntireColumn.Copy
line.

werafa's right; currently you're searching the whole sheet, you might only want to search the first row? In which case:
Set SupervisorCell = .Rows(1).Find(What:="Supervisor", After:=Range("A1"), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchFormat:=False).EntireColumn.Copy

We'll do the 'minus header' bit later…

[p45cal]

We'll do the 'minus header' bit later…
Set Destn = wsDestination.Range("A2")
and later:
SupervisorCell.EntireColumn.Resize(.Rows.Count - 1).Offset(1).Copy Destn

[ImThatGuy]

Difficult to work blind, but try this snippet instead of you errant code block to help debug problem:
Set Destn = wsDestination.Range("A1") 'note that it's A1 and not A2 since an entire column won't fit if you paste it to A2.
With wsSource
'Look for value and copy column
Set SupervisorCell = Nothing
'note the added dot before Cells in the next line.
Set SupervisorCell = .Cells.Find(What:="Supervisor", After:=Range("A1"), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows).EntireColumn.Copy
If SupervisorCell Is Nothing Then
MsgBox "no Supervisor found in sheet " & wsSource.Name & " of " & wbSource.Name
Else
Application.Goto SupervisorCell
MsgBox "Selected cell found - check it's what you expect."
'Select Destination WS, column A and paste
SupervisorCell.EntireColumn.Copy Destn
Set Destn = Destn.Offset(, 1) 'move the destination to the next column.
End If
End With


If you're using a PC (not a Mac) then it could also be safer to add SearchFormat:=False to the:
Set SupervisorCell = .Cells.Find(What:="Supervisor", After:=Range("A1"), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchFormat:=False).EntireColumn.Copy
line.

werafa's right; currently you're searching the whole sheet, you might only want to search the first row? In which case:
Set SupervisorCell = .Rows(1).Find(What:="Supervisor", After:=Range("A1"), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchFormat:=False).EntireColumn.Copy

We'll do the 'minus header' bit later…

Thank y'all for the responses. It's appreciated! I am going to be tied up for the next day or so but I will try to get back to y'all with the results as soon as I can.

Few responses:
I am only searching in the first row, I will add that, thanks!
I tried to use

Dim aCells as range
acells = cells.find........
as werafa suggested, and it did not work for me. It could be due to the fact I used it with the same paste method as I currently have.

It appears the code is performing the search, find, and copy as is written, but not the paste because when the code "stops" working I have the marching ants around the supervisor column. So I believe the issue is in the paste block.


Apologies I thought I attached the file the first time. I have attached a copy of the file (Again with the folder path removed).

[p45cal]

That's good; now we need a representative file that you interrogate, several if they're significantly different from each other especially regarding where 'Supervisor' might be found.

[ImThatGuy]

That's good; now we need a representative file that you interrogate, several if they're significantly different from each other especially regarding where 'Supervisor' might be found.

Source Files attached. I cleared out all data except for some generic values in the supervisor column.

In the three files Supervisor is located in:
Column T
Column AW
Column BK

22975
22974
22973

[p45cal]

Sub ImportAllData()
'Get Data from all Excel files in Event Response folder
Dim sFile As String 'file to open
Dim wsDestination As Worksheet, wbSource As Workbook, wsSource As Worksheet, hyperTarget As Long
Dim rngToCopy As Range, SupervisorHeaderCell As Range
hyperTarget = 2
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 SupervisorHeaderCell = Nothing
Set SupervisorHeaderCell = .Rows(1).Find(What:="Supervisor", After:=Range("A1"), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchFormat:=False)
If SupervisorHeaderCell Is Nothing Then
MsgBox "no Supervisor column header found in sheet " & wsSource.Name & " of " & wbSource.Name
Else
Set rngToCopy = Range(SupervisorHeaderCell.Offset(1), .Cells(.Rows.Count, SupervisorHeaderCell.Column).End(xlUp))
With wsDestination
.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(rngToCopy.Rows.Count).Value = rngToCopy.Value
'Hyperlink to the source file:
.Hyperlinks.Add Anchor:=.Range("L" & hyperTarget), Address:=(pFolder & sFile), TextToDisplay:="Link - " & sFile
End With
End If
End With
'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
Set wsSource = Nothing
Set wbSource = Nothing
Set wsDestination = Nothing
End Sub
I see you have other column headers on the same destination worksheet; realise that this method won't work robustly if you want to use the same technique to import other columns from the source files because it doesn't handle the possibility of different columns in the same sourcefile having different last rows (as would be the case if there were blank cells at the bottom of any column you wanted to copy data from).
Take note of the comment on the On Error line:"'disable this line while debugging." which was hiding your errors and making it impossible to debug.

[ImThatGuy]

Sub ImportAllData()
'Get Data from all Excel files in Event Response folder
Dim sFile As String 'file to open
Dim wsDestination As Worksheet, wbSource As Workbook, wsSource As Worksheet, hyperTarget As Long
Dim rngToCopy As Range, SupervisorHeaderCell As Range
hyperTarget = 2
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 SupervisorHeaderCell = Nothing
Set SupervisorHeaderCell = .Rows(1).Find(What:="Supervisor", After:=Range("A1"), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchFormat:=False)
If SupervisorHeaderCell Is Nothing Then
MsgBox "no Supervisor column header found in sheet " & wsSource.Name & " of " & wbSource.Name
Else
Set rngToCopy = Range(SupervisorHeaderCell.Offset(1), .Cells(.Rows.Count, SupervisorHeaderCell.Column).End(xlUp))
With wsDestination
.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(rngToCopy.Rows.Count).Value = rngToCopy.Value
'Hyperlink to the source file:
.Hyperlinks.Add Anchor:=.Range("L" & hyperTarget), Address:=(pFolder & sFile), TextToDisplay:="Link - " & sFile
End With
End If
End With
'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
Set wsSource = Nothing
Set wbSource = Nothing
Set wsDestination = Nothing
End Sub
I see you have other column headers on the same destination worksheet; realise that this method won't work robustly if you want to use the same technique to import other columns from the source files because it doesn't handle the possibility of different columns in the same sourcefile having different last rows (as would be the case if there were blank cells at the bottom of any column you wanted to copy data from).
Take note of the comment on the On Error line:"'disable this line while debugging." which was hiding your errors and making it impossible to debug.

This worked perfectly, thank you p45cal!!!!