Pull data from external workbook to active workbook based on a specific cell value

[charchar001]

Hey guys,

I'm in somewhat of a pickle. I have two workbooks, the first lets call "tool.xlsm" and the other "hours.xlsx", what i am trying to do is within "tool" the user will input a value in cell Q9 and from there I need to run a macro to take that value and search that value in "hours" by either using the sheet name which is laid out as "shortname (user value)" or within the sheet itself which would be in the format of "2-user value". This workbook will always be adding a new sheet, so the code has to cycle threw all of them. Once that sheet has been located it needs to run a VLOOKUP to match available options from the Hours worksheet to the tools worksheet.

So here is how sheets are titled in Hours:

Data within sheet:

Man power	411
Time	1000
Part	1555
Alarm	111
Package	526
test	45

Not every sheet will have every option hence the Vlookup to place the data in the correct location.

The code i have is somewhat a hodge podge of multiple attempts:
Tools WB is the only one open but my code opens hours to attempt to use the user input to correct it.
My issue is that i can't get the sheet to change or search for the one i need.
As far as vlookup goes I won't know the sheet name so I can't create a link to it and hard code it which I know how to do.
I am aware the Collect data sub is not encompassing of all the subs only because i was trying to troubleshoot.
I am trying data query but not that great with it. If you think that is a better option I am all for it.

Sub Collect_Data()
Dim PID As String
Dim shrtnme As String
Dim shtnme As String
PID = Range("Q9").Value
shrtnme = Range("Q8").Value
'Open workbook
open_hours
End Sub

Sub open_hours()

Workbooks.Open _
    Filename:="C:\Users\chaudri\Documents\tool test files\Estimated Package Hours.xlsx"
    ReadOnly = True
On Error Resume Next
    ThisWorkbook.Sheets(Worksheets("Instruction").Range("n18").Value).Activate
End Sub
Sub Find_Hours()
    Dim strWSName As String
    
    strWSName = InputBox("Enter the PID to serach for")
    If strWSName = vbNullString Then
        MsgBox "can't find"
        Exit Sub
    End If
    
If SheetExists(strWSName) Then
        Worksheets(strWSName).Activate
    Else
        'look if it at least contains part of the name
        Dim s As Worksheet
        For Each s In ThisWorkbook.Sheets
            If InStr(s.Name, strWSName) > 0 Then
                s.Activate
                Exit Sub
            End If
        Next s
        MsgBox "That sheet name does not exist!"
    End If
End Sub
Function SheetExists(strWSName As String) As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = Worksheets(strWSName)
    If Not ws Is Nothing Then SheetExists = True
End Function

 

[dmt32]

Hi,
read your post couple of times & not sure I fully follow however, having read your codes I have attempted to tidy up what I think you are trying to do

Sub Collect_Data()
    Dim PID As String, shrtnme As String
     Dim wsData As Worksheet
    
    Set wsData = ThisWorkbook.Worksheets("Sheet1")
    
    With wsData
        PID = .Range("Q9").Value
        shrtnme = .Range("Q8").Value
    End With
    
'Open workbook & find hours
    Find_Hours strWSName:=PID
    
    'do other stuff here

End Sub


Sub Find_Hours(ByVal strWSName As String)
    Dim FileName As String, FilePath As String
    Dim SheetExists As Boolean
    Dim wb As Workbook
    Dim ws As Worksheet
    

    FilePath = "C:\Users\chaudri\Documents\tool test files\"
    FileName = "Estimated Package Hours.xlsx"
    
    
    On Error GoTo myerror
    If Len(strWSName) = 0 Then Err.Raise 59, , "Please Enter Sheet Name"
    
    Application.ScreenUpdating = False
    Set wb = Workbooks.Open(FileName:=FilePath & FileName, ReadOnly:=True)
    
'look if it at least contains part of the name
        For Each ws In wb.Worksheets
            SheetExists = CBool(ws.Name = strWSName)
            If SheetExists Then Exit For
        Next ws
        
        If SheetExists Then
        
        'Do Your Stuff Here
            MsgBox ws.Name
        
        Else
'sheet not found
            Err.Raise 9, , strWSName & Chr(10) & "That sheet name does not exist!"
        
        End If
          
myerror:
'close workbook
    If Not wb Is Nothing Then wb.Close False
    Application.ScreenUpdating = True
'report errors
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
      
End Sub

Change the Sheet name shown in BOLD in the first code as required.

Not intended as fully working solution bit Hopefully, goes in right direction to help you.

Dave

 

[charchar001]

Sorry about that, scratching my head so hard earlier that all made sense to me.

To break it down:
This code would all be in Tools.xlsm, the sheet where the user will be placing the inputs (a five character value in cell Q9 on the instructions tab.i.e
4B461, 3Y891, 3M641 or something along those lines)

On the instructions tab after the user types into cell Q9, I want a macro to run that will fill in cells M8:M15 with data that be pulled from Hours.xlsx.

But before that can happen the code needs to be able to parse through the data, and find the appropriate sheet where that data is contained. Part of the sheet name is what the user inputs.

Theoretically this is what the code should do,
1. After user has typed in value in Q9, search for correct sheet in Hours.Xlsx
2. Activate sheet (probably not necessary, maybe it just needs the sheet name to be known to run the data pull)
3. Depending on if that sheet in hours has for instance 2 out of 6 options and those are to go in M8 and M11 to fill that out. (Data will be provided in next comment to assist in making sense of what I mean)

 

[charchar001]

I guess i can't add files.
Screen shots are as follows the box right of "PID" is where the user will enter that 5 character value. The current code i have written into the sheet code is to call on any macro i want once that cell changes.

From there the macro should go through the hours file:

Data sets look similar to those above it can vary from tab to tab. and collect the data from the corresponding sheet and copy it over to the Tool WB.
For example on the sheet EMP-KM Cell C5 would go to C12 in Tools.xlsm's instructions tab. But in the case of BTG-P2, Cell C5 would go to C10 on the instructions tab.

I have all the other stuff figured out i just can't automate the data collection part yet. Hopefully this helps in explaining what i need help with

 

[dmt32]

are you able to place copy of each workbook with sample data in a dropbox & provide link to it here?

Dave

 

[charchar001]

Dave,
Here is the link to the google drive Files

 

[dmt32]

ok will take a look

Dave

 

[charchar001]

ok will take a look

Dave

Thanks! I really appreciate the help!

 

[dmt32]

Hi,

An issue I encountered with your project is that you have merged cells in your ranges. Merged cells are a programmer’s nightmare & would suggest when developing workbooks that use VBA which reads / writes to ranges, to try and avoid including them.

I have amended code I posted earlier which is a bit clunky & if had more time may be able to clean it up further but hopefully will produce correct result with your merged cells.



Replace ALL code in your Module2 with following codes:

Sub Collect_Data(ByVal ws As Object)
    Dim PID As String, FileName As String
    Dim FilePath As String
    Dim i As Integer
    Dim Hours As Variant
    Dim FoundCell As Range
    
    
'*****************************************************************************************************************
'****************************************************SETTINGS*****************************************************

    FilePath = "C:\Users\chaudri\Documents\tool test files\"
    FileName = "Estimated Package Hours.xlsx"
    
    PID = ws.Range("Q9").Value
    
'*****************************************************************************************************************
    
    If Right(FilePath, 1) <> "\" Then FilePath = FilePath & "\"
    
    Application.EnableEvents = False
    
  
'Open workbook & find hours
    Find_Hours FullFileName:=FilePath & FileName, strWSName:=PID, HoursData:=Hours
    
'set values to 0
    ws.Range("$M$8:$M$15").Value = 0

'sheet not found
    If Not IsArray(Hours) Then GoTo exitsub

'update table
    For i = 1 To UBound(Hours, 1)
'locate in range, each heading in array
        Set FoundCell = ws.Range("$K$8:$M$15").Find(Hours(i, 1), LookIn:=xlFormulas, _
                                                                        LookAt:=xlWhole, _
                                                                        SearchOrder:=xlByRows, _
                                                                        SearchDirection:=xlNext, _
                                                                        MatchCase:=False)
 'enter hours to range
        If Not FoundCell Is Nothing Then FoundCell.Offset(, 1).Value = Hours(i, 2)
        Set FoundCell = Nothing
    Next i
    
exitsub:
    Application.EnableEvents = True
End Sub


Sub Find_Hours(ByVal FullFileName As String, ByVal strWSName As String, ByRef HoursData As Variant)
    Dim arr() As Variant
    Dim i As Integer
    Dim SheetExists As Boolean
    Dim rng As Range, cell As Range
    Dim wb As Workbook
    Dim ws As Worksheet
    
    On Error GoTo myerror
    If Len(strWSName) = 0 Then Err.Raise 59, , "Please Enter Sheet Name"
    
    Application.ScreenUpdating = False
    
'open hours workbook
    Set wb = Workbooks.Open(FileName:=FullFileName, ReadOnly:=True)
    
'locate PID sheet
        For Each ws In wb.Worksheets
            SheetExists = CBool(ws.Name Like "*" & strWSName & "*")
            If SheetExists Then Exit For
        Next ws
        
        If SheetExists Then
'get size of range
            Set rng = ws.Range(ws.Range("A3"), ws.Range("A" & ws.Rows.Count).End(xlUp))
'size array
            ReDim arr(1 To rng.Rows.Count, 1 To 2)
'populate array elements
            For Each cell In rng.Cells
                i = i + 1
'field name
                arr(i, 1) = Trim(cell.Value)
'value
                arr(i, 2) = cell.Offset(, 1).Value
            Next cell
'return array
            HoursData = arr
        Else
'sheet not found
            Err.Raise 9, , strWSName & Chr(10) & "That sheet name does not exist!"
            
        End If
          
myerror:
'close workbook
    If Not wb Is Nothing Then wb.Close False
    Application.ScreenUpdating = True
'report errors
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
      
End Sub

You will also need to update the first part of the worksheet_change event code as follows

Private Sub Worksheet_Change(ByVal Target As Range)
'Sub to prompt Collect_Data macro based on the PID being typed in

If Not Intersect(Target, Me.Range("Q9")) Is Nothing Then
    If Len(Target.Value) > 0 Then Call Collect_Data(Me)
Exit Sub
End If

'REST OF YOUR CODE

Hopefully, this will do what you want

Dave

 

[charchar001]

Thank you Dave! It does seem to work.

I was unaware of many of these functions so thanks for the things i can read up on!

Just to learn for future VBA endeavors, so an array in this case using "arr(i, 1) = Trim(cell.Value)" acts like a vlookup function correct?
You mentioned Merged cells being an issue, can it be done in the future to create a sub to unmerge cells then remerge them? Or that even a feasible option as data sets may change?
As far as the worksheet change code. What is the purpose of "(Me)" in this "Call Collect_Data(Me)"? Is there a benefit to putting something in there? Or is it just calling a local sub?
I usually leave the parenthesis field empty, hence the question

Once again thank you!!
?