Need help with variables.

[HansNewBie]

Dear forum readers,
I am having a problem with a VBA program that I wrote (Excel-VBA).

To start with some context.
I am a newbie when it comes to programming in VBA, so that been said.. 
I work in a company that uses a lot of individual files, called bricks.
All bricks (Excel-files) reside in one folder.

Each brick (individual file) has a title and subtitle (always the first and second filled row) and a type of the status of the product: (Mainstream, Emerging (R & D), Containment, Retirement).

For example:
File(s) --> Brick: Computer client operating system.xls

Content:
- Title: Client computers
- Subtitle: Operating systems

Followed by the status:
- Emerging (R & D)
o Windows 1010
o Apple IOS 398393
- Mainstream
o Windows 10
o Apple 123
- Containment
o Windows 7
- Retirement
o Windows 98
o Commodore 64
o MSX 2


I ‘wrote’ a program that:
- Reads all the Excel files in a specific folder
- Reads the title and subtitle
- Reads all rows between (for example) Mainstream and Emerging
- Puts all gathered information in ONE destination Excel-file (i.e. Title, Subtitle and information between for instance Mainstream and emerging)

So here is my/the challenge.
1. Sometimes people are filling the title and subtitle a few rows higher or lower, but it’s always (title first followed by a subtitle).
o I like to read the first and second non-blank rows.
o If someone forget to put in a title or subtitle I like to fill the variable with “No title or subtitle found”
2. Sometimes people are filling information (Emerging, Mainstream, Containment, et cetera) in column B instead or A.
o I like to fetch the information between (for example) Information and Emerging (the row), even if somebody puts the information in column B, C, D et cetera.

My ‘program’ works, but not always (sometimes it skips information/row).
And I know, it looks more like a spaghetti program, so my question is.
Can anyone help me with this challenge and provide me with some code that is easy to interpret. 

I like to add 3 attachments, but I am looking how to...

Option Explicit
Dim i As Integer
Dim Mainstream_Row As Integer
Dim Emerging_Row As Integer
Dim MainStream_Value As String
Dim Go_Vertical As Integer
Dim Value As String
Dim x As Integer
Dim Title As String
Dim SubTitle As String
Dim DestinationWB As Workbook
Dim SourceWB As Workbook
Dim strF As String, strP As String
Dim Various_wb As Workbook
Dim ws As Worksheet
Dim All_MainStream_Items As String
Dim CountY As Integer
Dim FileCount As Integer
Dim Count_strF As String
Dim rng As Range
Dim Dest_Worksheet
Dim WScriptShell



 Sub OpenClose_Excel_Files()                ' Read different Excel files and gather information to put in the summary output file
    FileCount = 0
    CountY = 1                              ' VERY IMPORTANT, otherwise the bricks will start to low.
    Set Various_wb = ActiveWorkbook         ' Make this workbook active
    Various_wb.Activate                     ' Activate Source workbook again
    Dest_Worksheet = "Output"
    strP = "C:\Temp\Excel"    ' Change for the path of your folder
    strF = Dir(strP & "\*.xlsx")            ' Change as required
    Count_strF = Dir(strP & "\*.xlsx")      ' Change as required
    '   MsgBox "Opening file " & strP & "\" & strF & ".", vbInformation, "Open File."
      
    Do While strF <> vbNullString
'        On Error Resume Next
        
        Set Various_wb = Workbooks.Open(strP & "\" & strF)
        Set ws = Various_wb.Sheets(1)   ' Uses first sheet or if all the same names then ws.Sheets("yoursheet")
        FileCount = FileCount + 1       ' Count all files in folder. When script is finished, show total number of found files.
        Call Read_Title_SubTitle        ' Sub for reading title and subtitle
        Call Get_MainStream_Emerging    ' Sub for reading all mainstream items
        Call Write_Output_Summary       ' Sub for writing all data in new sheet (summary of all information that is gathered from different sheets
  '      MsgBox "Closing file " & strP & "\" & strF & ".", vbInformation, "Close File."
        strF = Dir()
    Loop
 
  
   MsgBox "Finished the procedure." & vbNewLine & "Counted " & FileCount & " bricks", vbInformation, "Gathering bricks for status."
   Worksheets(Dest_Worksheet).Rows(1).VerticalAlignment = xlVAlignTop
   Worksheets(Dest_Worksheet).Columns("A:I").AutoFit
    
 
 End Sub
    

Sub Read_Title_SubTitle()           ' Read the Title and subtitle from each source file (Find first not blank en second non blank row)
    Worksheets("Brick").Activate    ' Activate Sheet
    x = 0
    For i = 1 To 10
        If Not Cells(i, 1) = "" Then
            Title = Range("A" & i).Value           ' Search for the FIRST value that is found in a row
            SubTitle = Range("A" & i + 1).Value    ' Search for the SECOND value that is found in a row
            x = 1
         End If
        If x = 1 Then
             GoTo lastline
        End If
        
    Next i
lastline:
'    MsgBox "Title (first now blank row) is: " & Title & vbNewLine & "Subtitle is (second non blank row): " & SubTitle, vbInformation, "Title and SubTitle"
End Sub



Sub Get_MainStream_Emerging()                   ' Get mainstream items from source files
 ' On Error Resume Next
    Worksheets("Brick").Activate                ' Activate Sheet
    
     Mainstream_Row = Application.WorksheetFunction.Match("Emerging (R & D)", Range("A1:A200"), 0)     ' Select start and end position between Mainstream (Row could be different)

     Emerging_Row = Application.WorksheetFunction.Match("Containment", Range("A1:A200"), 0) ' Select start and end position between Emerging (Row could be different)


    Do While Mainstream_Row < Emerging_Row - 1  ' Loop and read values
        Mainstream_Row = Mainstream_Row + 1
        MainStream_Value = Range("A" & Mainstream_Row).Value
        
        If MainStream_Value = Empty Then        ' In case of an empty A column
            MainStream_Value = Range("B" & Mainstream_Row).Value
        End If
    
    '    MsgBox "Mainstream_Row : " & MainStream_Value
        All_MainStream_Items = All_MainStream_Items & vbNewLine & MainStream_Value ' Summarize all rows items into one variable
    Loop

'If Err <> 0 Then
'   Set WScriptShell = CreateObject("WScript.Shell")
'    Title = "Error reading File: " & Count_strF ' Info to put in de source sheet
'    SubTitle = "Error reading File" ' Info to put in de source sheet
'    All_MainStream_Items = "Error reading File" ' Info to put in de source sheet
'    CreateObject("WScript.Shell").PopUp "Wow, what happend there?" & vbNewLine & "Please check this file for format. -> " & strF & ".", 3, "That 's not good at all!", vbExclamation
'End If
' On Error GoTo 0

End Sub
      
 
Sub Write_Output_Summary()              ' Writing all values from different Excel files to one Excel file, as a summary
    
    Various_wb.Close True
    Set SourceWB = ActiveWorkbook
    SourceWB.Activate                   ' Activate Source workbook again
        
    ' -----------------------------------------------------
    ' Setting up Lay out
    ' -----------------------------------------------------
    CountY = CountY + 1                 ' Enumerate row verticaly
    
    Range("A1:B100").Font.Size = 11
    Columns("A:C").HorizontalAlignment = xlCenter
    Cells.WrapText = True
    CountY = CountY + 1                 ' Enumerate row verticaly
    
    Set rng = Range("A" & CountY)
    With rng.Borders
        .LineStyle = xlContinuous
        .Color = vbBlack
        .Weight = xlMedium
    End With
    
    ' -----------------------------------------------------
    ' Putting information in destination file (SUMMARY)
    ' -----------------------------------------------------
    Range("A" & CountY).Interior.ColorIndex = 37
    Range("A" & CountY).Value = "File: " & strF & vbNewLine & "Title: " & Title & vbNewLine & "SubTitle: " & SubTitle & vbNewLine & All_MainStream_Items
    Range("A" & CountY).VerticalAlignment = xlTop
    CountY = CountY + 1             ' Enumarate rows verticaly
    Range("A" & CountY).Merge
    
    ' -----------------------------------------------------
    ' Clearing variables
    ' -----------------------------------------------------
    Title = ""
    SubTitle = ""
    All_MainStream_Items = ""

End Sub

The code resides in file: Destination_File_Summary.xls

Thank you very much for assistance.

 

[aRandomHelper]

o I like to read the first and second non-blank rows.
o If someone forget to put in a title or subtitle I like to fill the variable with “No title or subtitle found”

Only have enough time to work on these 2:

Sub Read_Title_SubTitle()           ' Read the Title and subtitle from each source file (Find first not blank en second non blank row)
    Dim i As Long, x As Long, f As Range
    Worksheets("Brick").Activate    ' Activate Sheet
    With ActiveSheet
        For i = 1 To .Rows.Count
            If Application.CountA(.Rows(i)) > 1 And x = 0 Then 'count number of non-blank cells
                'has not found a Title or Subtitle row
                'more than 1 non-blank cell in this row, might not be a Title/Subtitle row
                'see if we can find "Current" as shown in your brick file (template?)
tryFind:
                Set f = .Rows(i).Find("Current", lookat:=xlWhole)
                If Not f Is Nothing Then
                    '"Current" found in this row and have yet to see a Title/Subtitle row, Title/Subtitle omitted
                    If x = 0 Then Title = "No title or subtitle found"
                    SubTitle = "No title or subtitle found"
                    Exit For
                Else
                    '"Current" not found, maybe it was missed, let's try "Inventory"
                    Set f = .Rows(i).Find("Inventory", lookat:=xlWhole)
                    If Not f Is Nothing Then
                        '"Inventory" found in this row and have yet to see a Title/Subtitle row, Title/Subtitle omitted
                        If x = 0 Then Title = "No title or subtitle found"
                        SubTitle = "No title or subtitle found"
                        Exit For
                    Else
                        'Probably skipped Title/Subtitle rows and other header rows.
                        If x = 0 Then Title = "No title or subtitle found"
                        SubTitle = "No title or subtitle found"
                        Exit For
                    End If
                End If
            End If
            If Application.CountA(.Rows(i)) = 1 Then 'count number of non-blank cells
                Title = .Range("A" & i).Value           ' Search for the FIRST value that is found in a row
                x = 1
                i = i + 1
            End If
            If x = 1 Then
                If Application.CountA(.Rows(i)) = 1 Then 'count number of non-blank cells
                    SubTitle = .Range("A" & i).Value    ' Search for the SECOND value that is found in a row
                    GoTo lastline
                    Exit For 'you can use this if you don't want to use the above 'GoTo' command
                End If
                If Application.CountA(.Rows(i)) > 1 Then 'found Title but not Subtitle yet, might have been omitted.
                    GoTo tryFind
                End If
            End If
          
        Next i
    End With
lastline:
'    MsgBox "Title (first now blank row) is: " & Title & vbNewLine & "Subtitle is (second non blank row): " & SubTitle, vbInformation, "Title and SubTitle"
End Sub

Will check back tomorrow and help on the remaining point if no one else has provided anything yet.

Edit: amended code to include scenario of: has Title, no Subtitle

 

[HansNewBie]

Hello aRH,

Wow, that's a lot of coding. Thank you very much. I really appreciate it.
Unfortunately I have a little bit of trouble reading the code.
What I can see as a result, is that the code works perfect when it comes to reading the first two non blank rows. This is always the title and subtitle.

But what I don't understand is the code that reads the values between the headers such as: Mainstream and Emerging (R & D) Yellow marked in the screenshot.

In pseudo code I like to achieve this:
- Open each (different) workbook(s) that reside in a folder
- Find title and subtitle per workbook, independently if this resides in a different column (this works perfect). Put these values in two variables (Title and Subtitle)

- Find the row with the text containing "Mainstream" = (independently of the column)
- Find the row with text containing "Emerging (R & D)" = (independently of the column)
- Read all rows between Firstsection_Row_Number and LastSection_Row_Number and put this also in a variable that I can write as a total in a different workbook.
- Result: One destination workbook based on all Excel source files, with a summary of the TItles, SubTitles and a selection between (for instance) Mainstream and Emerging (R & D)

Again, thank you very much!

 

[aRandomHelper]

Amended Read_Title_SubTitle() again, since you wanted it to take the Title/Subtitle if it's in a different column. Previously the code only takes from column A.

Sub Read_Title_SubTitle()           ' Read the Title and subtitle from each source file (Find first not blank en second non blank row)
    Dim i As Long, x As Long, f As Range
    Worksheets("Brick").Activate    ' Activate Sheet
    With ActiveSheet
        For i = 1 To .Rows.Count
            If Application.CountA(.Rows(i)) > 1 And x = 0 Then 'count number of non-blank cells
                'has not found a Title or Subtitle row
                'more than 1 non-blank cell in this row, might not be a Title/Subtitle row
                'see if we can find "Current" as shown in your brick file (template?)
tryFind:
                Set f = .Rows(i).Find("Current", lookat:=xlWhole)
                If Not f Is Nothing Then
                    '"Current" found in this row and have yet to see a Title/Subtitle row, Title/Subtitle omitted
                    If x = 0 Then Title = "No title or subtitle found"
                    SubTitle = "No title or subtitle found"
                    Exit For
                Else
                    '"Current" not found, maybe it was missed, let's try "Inventory"
                    Set f = .Rows(i).Find("Inventory", lookat:=xlWhole)
                    If Not f Is Nothing Then
                        '"Inventory" found in this row and have yet to see a Title/Subtitle row, Title/Subtitle omitted
                        If x = 0 Then Title = "No title or subtitle found"
                        SubTitle = "No title or subtitle found"
                        Exit For
                    End If
                End If
            End If
            If Application.CountA(.Rows(i)) = 1 Then 'count number of non-blank cells
                'Title = .Range("A" & i).Value           ' Search for the FIRST value that is found in a row
                Title = .Cells(i, .Columns.Count).End(xlToLeft).Value          ' Search for the FIRST value that is found in a row
                x = 1
                i = i + 1
            End If
            If x = 1 Then
                If Application.CountA(.Rows(i)) = 1 Then 'count number of non-blank cells
                    'SubTitle = .Range("A" & i).Value    ' Search for the SECOND value that is found in a row
                    SubTitle = .Cells(i, .Columns.Count).End(xlToLeft).Value          ' Search for the FIRST value that is found in a row
                    GoTo lastline
                    Exit For 'you can use this if you don't want to use the above 'GoTo' command
                End If
                If Application.CountA(.Rows(i)) > 1 Then 'found Title but not Subtitle yet, might have been omitted.
                    GoTo tryFind
                End If
            End If
            
        Next i
    End With
lastline:
'    MsgBox "Title (first now blank row) is: " & Title & vbNewLine & "Subtitle is (second non blank row): " & SubTitle, vbInformation, "Title and SubTitle"
End Sub

Regarding this:

- Read all rows between Firstsection_Row_Number and LastSection_Row_Number and put this also in a variable that I can write as a total in a different workbook.

Will each row always only have 1 cell filled?
If it may contain more than 1 cell per row then it'll get slightly more complicated.
And if so, do you want the destination to have multiple cells filled as well, or all info cramped into a single cell?

 

[HansNewBie]

Will each row always only have 1 cell filled?
If it may contain more than 1 cell per row then it'll get slightly more complicated.
And if so, do you want the destination to have multiple cells filled as well, or all info cramped into a single cell?

Question:
Will each row always only have 1 cell filled? If it may contain more than 1 cell per row then it'll get slightly more complicated.

My Answer:
Yes, but sometimes people make the mistake by filling in column B instead of column A or visa versa (please see: Source_File_Example.png).
I tried to solve this with (pseudo code) --> If Range(A:row_number) = empty then read range(B:row_number). It is always one of the two columns (A or B).

Question:
And if so, do you want the destination to have multiple cells filled as well, or all info cramped into a single cell?

My Answer:
If everything is put together in different variables that would be fine, such as: Title, Subtitle and everything that is found between the rows for instance: Mainstream - Emerging (R&D).
I can put this information in one cell and 'break it down' with a VBNewLine for instance. I did this with my original spaghetti script

I added two pictures to provide someadditional context.

Thank you again.

 

[HansNewBie]

Sorry. I uploaded the wrong attachment.
This is the right source file example.

 

[aRandomHelper]

So here's the updated code for extracting the filled info, if I understood you correctly.

Make sure you declare these global variables, currently you have only Mainstream items:

Dim All_MainStream_Items As String
Dim All_Emerging_Items As String
Dim All_Containment_Items As String
Dim All_Retirement_Items As String

Sub Get_MainStream_Emerging()                   ' Get mainstream items from source files
    Dim getMainstream As Boolean, getEmerging As Boolean, getContainment As Boolean, getRetirement As Boolean
    Dim i As Long, j As Long, s
   
    'Set any of below to False if you don't want to retrieve those info
    getMainstream = True
    getEmerging = True
    getContainment = True
    getRetirement = True
   
    Worksheets("Brick").Activate                ' Activate Sheet
   
    All_MainStream_Items = ""
    All_Emerging_Items = ""
    All_Containment_Items = ""
    All_Retirement_Items = ""
    With ActiveSheet
        For i = 1 To .UsedRange.Rows.Count
            s = .Cells(i, "A").Value
           
            Select Case True
                Case s Like "Mainstream" And getMainstream
                    For j = i + 1 To i + 100
                        If Not .Cells(j, "A").Value Like "Emerging*" And .Cells(j, .Columns.Count).End(xlToLeft).Value <> "" Then
                            All_MainStream_Items = All_MainStream_Items & vbNewLine & .Cells(j, .Columns.Count).End(xlToLeft).Value
                        Else
                            Exit For
                        End If
                    Next
                Case s Like "Emerging*" And getEmerging
                    For j = i + 1 To i + 100
                        If Not .Cells(j, "A").Value Like "Containment" And .Cells(j, .Columns.Count).End(xlToLeft).Value <> "" Then
                            All_Emerging_Items = All_Emerging_Items & vbNewLine & .Cells(j, .Columns.Count).End(xlToLeft).Value
                        Else
                            Exit For
                        End If
                    Next
                Case s Like "Containment" And getContainment
                    For j = i + 1 To i + 100
                        If Not .Cells(j, "A").Value Like "Retirement" And .Cells(j, .Columns.Count).End(xlToLeft).Value <> "" Then
                            All_Containment_Items = All_Containment_Items & vbNewLine & .Cells(j, .Columns.Count).End(xlToLeft).Value
                        Else
                            Exit For
                        End If
                    Next
               
                Case s Like "Retirement" And getRetirement
                    For j = i + 1 To i + 100
                        If Not .Cells(j, "A").Value Like "Rationale" And .Cells(j, .Columns.Count).End(xlToLeft).Value <> "" Then
                            All_Retirement_Items = All_Retirement_Items & vbNewLine & .Cells(j, .Columns.Count).End(xlToLeft).Value
                        Else
                            Exit For
                        End If
                    Next
               
            End Select
        Next
    End With
    s = IIf(All_MainStream_Items <> "", "Mainstream items: " & All_MainStream_Items, "") & _
        IIf(All_Emerging_Items <> "", vbNewLine & vbNewLine & "Emerging items: " & All_Emerging_Items, "") & _
        IIf(All_Containment_Items <> "", vbNewLine & vbNewLine & "Containment items: " & All_Containment_Items, "") & _
        IIf(All_Retirement_Items <> "", vbNewLine & vbNewLine & "Retirement items: " & All_Retirement_Items, "")
       
    MsgBox s
End Sub

If you noticed, there are now 4 boolean variables that you can set as True if you want to extract those info. The MsgBox s is just my way to test how the output looks like, remove that if you don't need it.

Now you can think of how to transfer all of those info to your destination worksheet. Let me know if you still need help on that.

 

[HansNewBie]

So here's the updated code for extracting the filled info, if I understood you correctly.

Make sure you declare these global variables, currently you have only Mainstream items:

Dim All_MainStream_Items As String
Dim All_Emerging_Items As String
Dim All_Containment_Items As String
Dim All_Retirement_Items As String

Sub Get_MainStream_Emerging()                   ' Get mainstream items from source files
    Dim getMainstream As Boolean, getEmerging As Boolean, getContainment As Boolean, getRetirement As Boolean
    Dim i As Long, j As Long, s
  
    'Set any of below to False if you don't want to retrieve those info
    getMainstream = True
    getEmerging = True
    getContainment = True
    getRetirement = True
  
    Worksheets("Brick").Activate                ' Activate Sheet
  
    All_MainStream_Items = ""
    All_Emerging_Items = ""
    All_Containment_Items = ""
    All_Retirement_Items = ""
    With ActiveSheet
        For i = 1 To .UsedRange.Rows.Count
            s = .Cells(i, "A").Value
          
            Select Case True
                Case s Like "Mainstream" And getMainstream
                    For j = i + 1 To i + 100
                        If Not .Cells(j, "A").Value Like "Emerging*" And .Cells(j, .Columns.Count).End(xlToLeft).Value <> "" Then
                            All_MainStream_Items = All_MainStream_Items & vbNewLine & .Cells(j, .Columns.Count).End(xlToLeft).Value
                        Else
                            Exit For
                        End If
                    Next
                Case s Like "Emerging*" And getEmerging
                    For j = i + 1 To i + 100
                        If Not .Cells(j, "A").Value Like "Containment" And .Cells(j, .Columns.Count).End(xlToLeft).Value <> "" Then
                            All_Emerging_Items = All_Emerging_Items & vbNewLine & .Cells(j, .Columns.Count).End(xlToLeft).Value
                        Else
                            Exit For
                        End If
                    Next
                Case s Like "Containment" And getContainment
                    For j = i + 1 To i + 100
                        If Not .Cells(j, "A").Value Like "Retirement" And .Cells(j, .Columns.Count).End(xlToLeft).Value <> "" Then
                            All_Containment_Items = All_Containment_Items & vbNewLine & .Cells(j, .Columns.Count).End(xlToLeft).Value
                        Else
                            Exit For
                        End If
                    Next
              
                Case s Like "Retirement" And getRetirement
                    For j = i + 1 To i + 100
                        If Not .Cells(j, "A").Value Like "Rationale" And .Cells(j, .Columns.Count).End(xlToLeft).Value <> "" Then
                            All_Retirement_Items = All_Retirement_Items & vbNewLine & .Cells(j, .Columns.Count).End(xlToLeft).Value
                        Else
                            Exit For
                        End If
                    Next
              
            End Select
        Next
    End With
    s = IIf(All_MainStream_Items <> "", "Mainstream items: " & All_MainStream_Items, "") & _
        IIf(All_Emerging_Items <> "", vbNewLine & vbNewLine & "Emerging items: " & All_Emerging_Items, "") & _
        IIf(All_Containment_Items <> "", vbNewLine & vbNewLine & "Containment items: " & All_Containment_Items, "") & _
        IIf(All_Retirement_Items <> "", vbNewLine & vbNewLine & "Retirement items: " & All_Retirement_Items, "")
      
    MsgBox s
End Sub

If you noticed, there are now 4 boolean variables that you can set as True if you want to extract those info. The MsgBox s is just my way to test how the output looks like, remove that if you don't need it.

Now you can think of how to transfer all of those info to your destination worksheet. Let me know if you still need help on that.

Great, this works perfect!!!!! This saves me a lot of headache.
I have only one last question about finding the title and subtitle (first to non blank rows). Does the previous provided code work? I can't seem to get it working.

Thank you very much!!!!

 

[aRandomHelper]

Does the previous provided code work? I can't seem to get it working.

Apologies for that, I thought I could get away without testing the code.

So I went through it again and found a flaw here:

            If Application.CountA(.Rows(i)) = 1 Then 'count number of non-blank cells
                'Title = .Range("A" & i).Value           ' Search for the FIRST value that is found in a row
                Title = .Cells(i, .Columns.Count).End(xlToLeft).Value          ' Search for the FIRST value that is found in a row
                x = 1
                i = i + 1
            End If

Should be this:

            If Application.CountA(.Rows(i)) = 1 And x = 0 Then 'count number of non-blank cells
                'Title = .Range("A" & i).Value           ' Search for the FIRST value that is found in a row
                Title = .Cells(i, .Columns.Count).End(xlToLeft).Value          ' Search for the FIRST value that is found in a row
                x = 1
                i = i + 1
            End If

See if that fixes the problem.

 

[HansNewBie]

Hello aRH,

I just tested the code and everything works as it should be.
I am really over the moon with these results. No question (anymore) from my side anymore. You took a lot of work from my plate.

So I like to close this thread with a BIG THANK YOU for your effort. I really appreciateit it. ?

Best regards,

Hans