Conditionally lookup worksheet values inside import of multiple workbooks

rmorriso · Dec 4, 2010

Hello,

I have spent hours and hours reading forum threads, but cannot find enough pointers to solve this one completely on my own. So any help would be much appreciated

Task being attempted (Excel 2007):
1) Run a macro in new sheet (DataSummary) that scans a directory of workbooks and imports/links data from them, into a row for each.
2) For each workbook imported dynamically look up data in variably named worksheets based on summary page, but only if worksheets are selected (with TRUE/FALSE indicator) AND contain certain values (the Product Name is ProductA).

I have found a solution here to part 1, but not good enough at VBA to piece together part 2.

Here is the code for part 1, with commented stubs on what I think is needed:

Code:

Sub test()
  Dim myDir As String, fn As String, temp As String, ref As String
  With Application.FileDialog(msoFileDialogFolderPicker)
      If .Show = True Then
          myDir = .SelectedItems(1) & "\"
      Else
          Exit Sub
      End If
  End With
  n = 4
  fn = Dir(myDir & "*.xls")
  Do While fn <> ""
      If fn <> ThisWorkbook.Name Then
          n = n + 1: temp = "='" & myDir & "[" & fn & "]"
          With ThisWorkbook.Sheets("Sheet1")  '<- change to actual sheet name
              ' Put workbook name into column a
              .Cells(n, "a").Formula = fn
              ref = temp & "TTS-Summary'!"
              .Cells(n, "b").Formula = ref & "C5"
               ref = temp & "Details'!"
              .Cells(n, "c").Resize(, 3).Formula = _
                  Array(ref & "D11", ref & "D14", ref & "F5")
              '.Cells(n, "k").Resize(, 4).Formula = _
              '    Array(ref & "F10", ref & "F14", ref & "F16", ref & "F10")
               ref = temp & "IntecSummary'!"
              .Cells(n, "f").Resize(, 3).Formula = _
                  Array(ref & "F4", ref & "B4", ref & "B28")
              'Find out which worksheets are active or TRUE
              'Loop through them
              'Test if they have ProductA
              'If they do have ProductA collect values from them
   
              .Rows(1).Value = .Rows(1).Value
          End With
      End If
      fn = Dir
  Loop
  End Sub

For context here is the DataSummary sheet and what target data populates each row in bold. Example data is in row 4:

Excel Workbook

A

B

C

D

E

F

G

H

I

J

K

1

File name

Customer name

Country

Project Title

Date

Include

Sheet Name

Product Name

Currency

Volume

List Price

2

Sheet reference

TTS-Summary

Details

Summary

Sheet where Product = ProductA

3

Cell reference

C5

D11

D14

F5

F4

B4

B1

E1

B2

E2

4

TTS JohnL 2008.xl

John L

UK

Blah

03/10/2010

TRUE

Deal24

ProductA

USD

2000

20

DataSummary

The Summary sheet contains the following. So we are only interested in sheets that are marked TRUE, of which there can be any number. There are only nine possibly active sheets

Excel Workbook

A

B

1

Sheet Name

Include?

2

Deal1

TRUE

3

Deal24

TRUE

4

Deal3

FALSE

5

Deal n

FALSE

6

Deal n

FALSE

7

Deal n

FALSE

8

Deal n

FALSE

9

Deal n

FALSE

10

Deal 9

FALSE

Summary

So I want to test the variably named worksheets to see if they are for ProductA and if so bring back the other data to the DataSummary worksheet

So Deal1 is not interesting as it’s not ProductA

Excel Workbook

A

B

C

D

E

1

Product:

ProductB

Currency:

GBP

2

Volume:

1000

List Price

30

Deal1

But Deal24 is relevant:

Excel Workbook

A

B

C

D

E

1

Product:

ProductA

Currency:

USD

2

Volume:

2000

List Price

20

Deal24

I suppose I need to loop around the worksheet names and see if they are TRUE and then use the names to check if ProductA is present.

Any pointers on code to use here that would work inside the import loop would be much apreciated.

Many thanks,

Rob.

rmorriso · Dec 5, 2010

Having slept on this, I think I'll begin with a couple of IF statements to test the first sheet and take it from there.

Regards,

Rob.

Memento audere semper!

rmorriso · Dec 7, 2010

Hi all,

This is how I got it to work. Probably not the most elegant (goto), but worked for me.

Data is slightly different to the sample to protect the innocent, but you'll get the gist.

Regards,

Rob.

Code:

Sub test()
Dim myDir As String, fn As String, temp As String
Dim ref As String, c As Integer, fnap As String, WsStr As String
Dim Sh1 As Worksheet, Bk1 As Workbook, Rng1 As Range, Str1 As String
Dim Sh2 As Worksheet, tref As String

With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show = True Then
        myDir = .SelectedItems(1) & "\"
    Else
        Exit Sub
    End If
End With
n = 4
fn = Dir(myDir & "*.xls")
Do While fn <> ""
    If fn <> ThisWorkbook.Name Then
        n = n + 1: temp = "='" & myDir & "[" & fn & "]"
        'fnap = "'" & myDir & fn & "'"
        fnap = myDir & fn

        With ThisWorkbook.Sheets("Sheet1")  '<- change to actual sheet name
            ' Put workbook name into column a
            .Cells(n, "a").Formula = fn
           
            'Find out which worksheets are active or TRUE
            p = 0
            'MsgBox (fnap)
            Set Bk1 = Workbooks.Open(fnap, UpdateLinks:=2, ReadOnly:=True, _
                            IgnoreReadOnlyRecommended:=True, CorruptLoad:=xlRepairFile)
                            
            With Bk1
                '.IsAddin = True
            End With
            
            If WorksheetExists("TTS-Summary") = 0 Then
                MsgBox ("Old TTS")
                GoTo MyEnd:
            End If

            Set Sh1 = Bk1.Sheets("IntecSummary")
            On Error GoTo 0
            
            ref = temp & "TTS-Summary'!"
            .Cells(n, "b").Formula = ref & "C5"
            
             ref = temp & "Details'!"
            .Cells(n, "c").Resize(, 3).Formula = _
                Array(ref & "D11", ref & "D14", ref & "F5")
            
            

            For c = 4 To 12
                Str1 = Sh1.Range("F" & c).Value2
                                                              
                'Check for column F Include? and column D Sheet OK?
                If (StrComp(Sh1.Range("F" & c).Value2, "True", 1) = 0) Then
                    If (StrComp(Sh1.Range("D" & c).Value2, "True", 1) = 0) Then
                    
                        'If they are TRUE check the product
                        WsStr = Sh1.Range("B" & c).Value2
                        
                        Set Sh2 = Bk1.Sheets(WsStr)
                        Str1 = Sh2.Range("C2").Value2
                        
                        If StrComp(Str1, "IntermediatE", 1) = 0 Then
                            ' Capture worksheet
                            ref = temp & "IntecSummary'!"
                            .Cells(n, "f").Resize(, 2).Formula = _
                                Array(ref & "F" & c, ref & "B" & c)
                                
                            tref = temp & WsStr & "'!"
                            p = p + 1
                            .Cells(n, "h").Resize(, 26).Formula = _
                                Array(tref & "C2", p, tref & "F18", _
                                        tref & "D19", tref & "F19", _
                                        tref & "D20", tref & "F20", _
                                        tref & "D21", tref & "F21", _
                                        tref & "D22", tref & "F22", _
                                        tref & "D23", tref & "F23", _
                                        tref & "D24", tref & "F24", _
                                        tref & "D25", tref & "F25", _
                                        tref & "F35", tref & "J35", _
                                        tref & "J37", _
                                        tref & "DC93", tref & "D93", _
                                        tref & "G93", tref & "H93", _
                                        tref & "J93", tref & "E93")
                        End If
                                        
                        If StrComp(Str1, "InterconnecT", 1) = 0 Then
                            Str1 = Sh2.Range("F28").Value2
                            If Len(Str1) > 0 Then
                                ' Capture worksheet
                                ref = temp & "IntecSummary'!"
                                .Cells(n, "f").Resize(, 2).Formula = _
                                    Array(ref & "F" & c, ref & "B" & c)
                                
                                tref = temp & WsStr & "'!"
                                p = p + 1
                                .Cells(n, "h").Resize(, 5).Formula = _
                                    Array("PREP", p, tref & "F18", _
                                                tref & "D28", tref & "F28")
                                .Cells(n, "aa").Resize(, 1).Formula = _
                                    Array(tref & "J37")
                            End If
                                              
                        End If
                    End If
                End If
                
            Next c
                      
            With Bk1
                .IsAddin = False
                .Close savechanges:=False
            End With
                          
                            
            '.Cells(n, "0").Resize(, 4).Formula _
            '    Array(ref & "F20", ref & "F18", ref & "F26", ref & "F28")
            
            .Rows(1).Value = .Rows(1).Value
            
            'GoTo MyEnd:
                        
        End With

    End If
MyEnd:
    fn = Dir
Loop

End Sub

Function WorksheetExists(WSName As String) As Boolean
On Error Resume Next
WorksheetExists = Worksheets(WSName).Name = WSName
End Function

Conditionally lookup worksheet values inside import of multiple workbooks

rmorriso

New Member

Excel Facts

rmorriso

New Member

rmorriso

New Member

Similar threads

Forum statistics

Share this page

Conditionally lookup worksheet values inside import of multiple workbooks

rmorriso

New Member

Excel Facts

rmorriso

New Member

rmorriso

New Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock