Count value when the value is a merged cell

[Macaron]

Hello, I'm a newbie to type VBA code.
Recently, I would like to create a series of VBA code in order to accelerate work.
Now, I have faced the problems below:
1. I would like to count the number of "LTG" which has 3 merged rows only.(shown in the uploaded image)
2. About the Find Function, I discovered that when "Remark" has merged 2 columns,
Find Function didn't work, so I have to find "*" or unmerged "Remark" columns. Is there any ways I can find the range of Remark columns within border area. I just want to the range which is below "Remark"(Range("X11")) to last row with border area(Range("X42")).

Sub Countnumber()
    Dim objNewWorkbook As Workbook
    Dim objNewWorksheet As Worksheet
    Dim LastColumn As Long
    Set objNewWorkbook = Excel.Application.Workbooks.Add
    Set objNewWorksheet = objNewWorkbook.Sheets(1)
    
    For i = 1 To ThisWorkbook.Sheets.Count
    objNewWorksheet.Cells(i, 1) = ThisWorkbook.Sheets(i).Name
    LastColumn = ThisWorkbook.Sheets(i).Cells.Find("*", LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    objNewWorksheet.Cells(i, 6).Value = WorksheetFunction.CountIf(ThisWorkbook.Sheets(i).Columns(LastColumn), "*LTG*")
    
    Next i
End Sub

Hope someone can help me..

 

[Alex Blakenburg]

Thanks! Does it show error in VBA code, when Find formula can’t find the “foundcell”? I got trouble in here

I tried my code with and invalid find string and on a column that was completely empty and both worked fine, it just showed everything as zero in the message box.


Your last sentence looks unfinished, what is the error message you are getting and what line is highlighted in the code when you click on the error message debug button ?

 

[Macaron]

I tried my code with and invalid find string and on a column that was completely empty and both worked fine, it just showed everything as zero in the message box.


Your last sentence looks unfinished, what is the error message you are getting and what line is highlighted in the code when you click on the error message debug button ?

I think that there is a problem about my code because I tried to run your code successfully. However, when I combined your code in mine, it showed "Object variable or with block variable not set" error message on

If foundCell.Address = FirstAddr Then

. It made me crazy.
By the way, I remembered that I have successfully run my code once.

Could you take a look?

Sub ListSheetNamesInNewWorkbookandCount()
    Dim objNewWorkbook As Workbook
    Dim objNewWorksheet As Worksheet
    Dim cntMerged As Long
    Dim cntNotMerged As Long
    Dim sht As Worksheet
    Dim wb As Workbook
    Dim rng As Range
    Dim foundCell As Range
    Dim strToFind As String
    Dim FirstAddr As String
   
    Set wb = ThisWorkbook
    Set wf = WorksheetFunction
    Set objNewWorkbook = Excel.Application.Workbooks.Add
    Set objNewWorksheet = objNewWorkbook.Sheets(1)
    
    cntMerged = 0
    cntNotMerged = 0
    strToFind = "MCB"
    
    
    For i = 1 To ThisWorkbook.Sheets.Count
    
    Set sht = wb.Sheets(i)
    Set rng = sht.Range("X:X")
    objNewWorksheet.Cells(i, 1) = sht.Name
    
    
    Set foundCell = rng.Find(What:=strToFind, After:=rng.Cells(1, 1), LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False)
        
        If Not foundCell Is Nothing Then
        FirstAddr = foundCell.Address
    
    End If
   
    Do Until foundCell Is Nothing
        If foundCell.MergeArea.Rows.Count > 1 Then
                cntMerged = cntMerged + 1
        Else
                cntNotMerged = cntNotMerged + 1
        End If
       

        Set foundCell = rng.FindNext(After:=foundCell)

        If foundCell.Address = FirstAddr Then
            
            Exit Do
        End If
    Loop



    objNewWorksheet.Cells(i, 2).Value = cntNotMerged
    objNewWorksheet.Cells(i, 3).Value = cntMerged
    
    Next i
    
        With objNewWorksheet
         .Rows(1).Insert
         .Cells(1, 1) = "NAME"
         .Cells(1, 1).Font.Bold = True
.Cells(1, 2) = "Submain SPN"
.Cells(1, 3) = "Submain TPN"

    End With
    
End Sub

 

[Alex Blakenburg]

OK I made these changes and then it worked for me:

Add this at the top with the other Dim statements:

Dim i As Long

Remove

Set wf = WorksheetFunction     'XXX Removed

 

[Macaron]

OK I made these changes and then it worked for me:

Add this at the top with the other Dim statements:

Dim i As Long

Remove

Set wf = WorksheetFunction     'XXX Removed

I found the problem. It didn't work on this sheet. I don't know why.

coding.xls

 

[Alex Blakenburg]

Change:

        If foundCell.Address = FirstAddr Then
            
            Exit Do
        End If

To this:

        If foundCell Is Nothing Then Exit Do
        If foundCell.Address = FirstAddr Then Exit Do

 

[Macaron]

Change:

        If foundCell.Address = FirstAddr Then
           
            Exit Do
        End If

To this:

        If foundCell Is Nothing Then Exit Do
        If foundCell.Address = FirstAddr Then Exit Do

I can run the code after changed. But why is it? Is it about the sheet format that made this error message?

 

[Alex Blakenburg]

I can run the code after changed. But why is it? Is it about the sheet format that made this error message?

I am glad you asked, that was interesting. There are in fact 3 scenarios and number 3 was failing.

1. Nothing found, no occurences of search string in range being searched.
   - Handled by first foundCell If statement > If Not foundCell Is Nothing Then
2. Multiple occurences, FindNext keeps looking and if you are not doing a replace eventually cycles back to the first occurence at which point you want to exit.
   - Handled by > Loop Until foundCell.Address = FirstAddr (moved this from inside the loop)
3. Single occurence. Unlike item 2 this did not loop which would have meant looping back to itself but produced a foundCell is Nothing.
   - Incorrectly handled in Microsoft Range.FindNext documentation by placing 2 tests in the one line as in this
   (modified to use our variable names) Loop While Not foundCell Is Nothing And foundCell.Address <> FirstAddr. This arrangement causes it to evaluate both expressions and the code errors our on foundCell.Address which is returning Nothing.
   - Incorrectly handled in my previous procedure by testing foundCell.Address <> FirstAddr "before" testing for Is Nothing with that test erroring out.

Below is a modified version of the code you had in the file that was in the link you provided that should cover this off.
Let me know how you go.

Sub ListSheetNamesInNewWorkbookandCount_Mod()
    Dim objNewWorkbook As Workbook
    Dim objNewWorksheet As Worksheet
    Dim cntMerged As Long
    Dim cntNotMerged As Long
    Dim sht As Worksheet
    Dim wb As Workbook
    Dim rng As Range
    Dim foundCell As Range
    Dim strToFind As String
    Dim FirstAddr As String
    Dim i As Long
  
    Set wb = ThisWorkbook
    Set objNewWorkbook = Excel.Application.Workbooks.Add
    Set objNewWorksheet = objNewWorkbook.Sheets(1)
   
    cntMerged = 0
    cntNotMerged = 0
    strToFind = "MCB"
   
    For i = 1 To ThisWorkbook.Sheets.Count
   
    Set sht = wb.Sheets(i)
    Set rng = sht.Range("X:X")
    objNewWorksheet.Cells(i, 1) = sht.Name   
   
    Set foundCell = rng.Find(What:=strToFind, After:=rng.Cells(1, 1), LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False)
       
    If Not foundCell Is Nothing Then
        FirstAddr = foundCell.Address
  
        Do
            If foundCell.MergeArea.Rows.Count > 1 Then
                    cntMerged = cntMerged + 1
            Else
                    cntNotMerged = cntNotMerged + 1
            End If
          
            Set foundCell = rng.FindNext(After:=foundCell)
               
            If foundCell Is Nothing Then Exit Do
   
        Loop Until foundCell.Address = FirstAddr
    End If

    objNewWorksheet.Cells(i, 2).Value = cntNotMerged
    objNewWorksheet.Cells(i, 3).Value = cntMerged
   
    Next i
   
    With objNewWorksheet
        .Rows(1).Insert
        .Cells(1, 1) = "NAME"
        .Cells(1, 1).Font.Bold = True
        .Cells(1, 2) = "Submain SPN"
        .Cells(1, 3) = "Submain TPN"
    End With
   
End Sub

 

[Macaron]

I am glad you asked, that was interesting. There are in fact 3 scenarios and number 3 was failing.

1. Nothing found, no occurences of search string in range being searched.
   - Handled by first foundCell If statement > If Not foundCell Is Nothing Then
2. Multiple occurences, FindNext keeps looking and if you are not doing a replace eventually cycles back to the first occurence at which point you want to exit.
   - Handled by > Loop Until foundCell.Address = FirstAddr (moved this from inside the loop)
3. Single occurence. Unlike item 2 this did not loop which would have meant looping back to itself but produced a foundCell is Nothing.
   - Incorrectly handled in Microsoft Range.FindNext documentation by placing 2 tests in the one line as in this
   (modified to use our variable names) Loop While Not foundCell Is Nothing And foundCell.Address <> FirstAddr. This arrangement causes it to evaluate both expressions and the code errors our on foundCell.Address which is returning Nothing.
   - Incorrectly handled in my previous procedure by testing foundCell.Address <> FirstAddr "before" testing for Is Nothing with that test erroring out.

Below is a modified version of the code you had in the file that was in the link you provided that should cover this off.
Let me know how you go.

Sub ListSheetNamesInNewWorkbookandCount_Mod()
    Dim objNewWorkbook As Workbook
    Dim objNewWorksheet As Worksheet
    Dim cntMerged As Long
    Dim cntNotMerged As Long
    Dim sht As Worksheet
    Dim wb As Workbook
    Dim rng As Range
    Dim foundCell As Range
    Dim strToFind As String
    Dim FirstAddr As String
    Dim i As Long
 
    Set wb = ThisWorkbook
    Set objNewWorkbook = Excel.Application.Workbooks.Add
    Set objNewWorksheet = objNewWorkbook.Sheets(1)
 
    cntMerged = 0
    cntNotMerged = 0
    strToFind = "MCB"
 
    For i = 1 To ThisWorkbook.Sheets.Count
 
    Set sht = wb.Sheets(i)
    Set rng = sht.Range("X:X")
    objNewWorksheet.Cells(i, 1) = sht.Name 
 
    Set foundCell = rng.Find(What:=strToFind, After:=rng.Cells(1, 1), LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False)
     
    If Not foundCell Is Nothing Then
        FirstAddr = foundCell.Address
 
        Do
            If foundCell.MergeArea.Rows.Count > 1 Then
                    cntMerged = cntMerged + 1
            Else
                    cntNotMerged = cntNotMerged + 1
            End If
        
            Set foundCell = rng.FindNext(After:=foundCell)
             
            If foundCell Is Nothing Then Exit Do
 
        Loop Until foundCell.Address = FirstAddr
    End If

    objNewWorksheet.Cells(i, 2).Value = cntNotMerged
    objNewWorksheet.Cells(i, 3).Value = cntMerged
 
    Next i
 
    With objNewWorksheet
        .Rows(1).Insert
        .Cells(1, 1) = "NAME"
        .Cells(1, 1).Font.Bold = True
        .Cells(1, 2) = "Submain SPN"
        .Cells(1, 3) = "Submain TPN"
    End With
 
End Sub

Sorry for my late reply! Im quite busy recently. I just restart my coding journey today.

Thanks for your detailed explanation! As for Single Occurrence(item 3), do you mean that the find function cannot not go back to first address of foundCell when there is only single occurrence ? Therefore, it shows Nothing when it searched in the second time.

Besides, I have a problem on my code. I tried to write new code for new counting item today. If I want to search 3 merged row only, shall I need to write “for each” function?

Example:

For each Cell In rng.UsedRange
If Cell.MergeArea.Rows.Count = 3 Then
TotalTPN = TotalTPN+1
End If
Next

 

[Alex Blakenburg]

As for Single Occurrence(item 3), do you mean that the find function cannot not go back to first address of foundCell when there is only single occurrence ? Therefore, it shows Nothing when it searched in the second time.

Correct.

I have a problem on my code. I tried to write new code for new counting item today. If I want to search 3 merged row only, shall I need to write “for each” function?

This really should be a different thread since it is quite different although related to the original issue.
The For Each Loop will count each merged cell 3 times (or as many times as specified in this line Cell.MergeArea.Rows.Count = 3.
It will look at each cell individually and then determine it part of a set of 3 and increment the counter. It won't know it has been included in a previous count. It could also be quite slow if it is a large spreadsheet.

Using Find on Formatting is bit quirky since it won't let you use FindNext. Here is the version that should do what you want.

Sub FindMergedRows()

    Dim rng As Range
    Dim foundCell As Range
    Dim FirstAddr As String
    Dim TotalTPN As Long

    With Application.FindFormat
        .WrapText = False
        .ShrinkToFit = False
        .MergeCells = True
    End With
    
    Set rng = ActiveSheet.UsedRange
        
    Set foundCell = rng.Find(What:="", after:=rng.Cells(1, 1), LookIn:=xlFormulas2, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=True)
    
    If Not foundCell Is Nothing Then
        FirstAddr = foundCell.Address
   
        Do
            If foundCell.MergeArea.Rows.Count = 3 Then
                TotalTPN = TotalTPN + 1
            End If
           
            'Set foundCell = rng.FindNext(after:=foundCell) ' <--- Doesn't work for SearchFormat
            Set foundCell = rng.Find(What:="", after:=foundCell, SearchFormat:=True)
                
            If foundCell Is Nothing Then Exit Do
    
        Loop Until foundCell.Address = FirstAddr
    End If
    
    ' Reset Find Format
    Application.FindFormat.Clear

End Sub

 

[Macaron]

Correct.


This really should be a different thread since it is quite different although related to the original issue.
The For Each Loop will count each merged cell 3 times (or as many times as specified in this line Cell.MergeArea.Rows.Count = 3.
It will look at each cell individually and then determine it part of a set of 3 and increment the counter. It won't know it has been included in a previous count. It could also be quite slow if it is a large spreadsheet.

Using Find on Formatting is bit quirky since it won't let you use FindNext. Here is the version that should do what you want.

Sub FindMergedRows()

    Dim rng As Range
    Dim foundCell As Range
    Dim FirstAddr As String
    Dim TotalTPN As Long

    With Application.FindFormat
        .WrapText = False
        .ShrinkToFit = False
        .MergeCells = True
    End With
   
    Set rng = ActiveSheet.UsedRange
       
    Set foundCell = rng.Find(What:="", after:=rng.Cells(1, 1), LookIn:=xlFormulas2, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=True)
   
    If Not foundCell Is Nothing Then
        FirstAddr = foundCell.Address
  
        Do
            If foundCell.MergeArea.Rows.Count = 3 Then
                TotalTPN = TotalTPN + 1
            End If
          
            'Set foundCell = rng.FindNext(after:=foundCell) ' <--- Doesn't work for SearchFormat
            Set foundCell = rng.Find(What:="", after:=foundCell, SearchFormat:=True)
               
            If foundCell Is Nothing Then Exit Do
   
        Loop Until foundCell.Address = FirstAddr
    End If
   
    ' Reset Find Format
    Application.FindFormat.Clear

End Sub

Could you help me take a look on these sheet and code?
I wrote what I want. But the results of counting can't achieve my expectation.

1. In sheet "DB-1" should show zero in "Other TPN" item, not "-8"
2. In sheet "DB" should show zero in "Other TPN" item, not "8"

Let me explain my expectation in Sheet "DB1",
1. Count 3 merged rows in "Remark" column, but excluding "SPACE" and "SPARE" that have 3 merged rows
2. Therefore, cntOtherTPNMerged should be equal to 8 at the beginning according to "DB1" sheet
3. There are no LIGHT that have 3 merged rows. Therefore, cntTPNLTG should be equal to 0 according to "DB1" sheet
4. After cntMerged is counted, cntMerged should be equal to 8 according to "DB1" sheet
5. Finally, output the value cntOtherTPNMerged - cntMerged -cntTPNLTG =0 to new sheet

In Sheet "DB",
1. Count 3 merged rows in "Remark" column, but excluding "SPACE" and "SPARE" that have 3 merged rows
2. Therefore, cntOtherTPNMerged should be equal to 8 at the beginning according to "DB" sheet
3. There are 8 LIGHT that have 3 merged rows. Therefore, cntTPNLTG should be equal to 8 according to "DB" sheet
4. After cntMerged is counted, cntMerged should be equal to 0 according to "DB" sheet
5. Finally, output the value cntOtherTPNMerged - cntMerged -cntTPNLTG =0 to new sheet

'Testing
Sub ListSheetNamesInNewWorkbookandCount()
    Dim objNewWorkbook As Workbook
    Dim objNewWorksheet As Worksheet
    Dim cntMerged As Long
    Dim cntNotMerged As Long
    Dim sht As Worksheet
    Dim wb As Workbook
    Dim rng As Range
    Dim rngRemark As Range
    Dim foundCell As Range
    Dim strToFind As String
    Dim FirstAddr As String
    Dim LastColumn As Long
    Dim foundOtherTPNCell As Range 'new counting item
    Dim cntOtherTPNMerged As Long 'new counting item
    Dim cntTPNLTG As Long 'new counting item
   
    Set wb = ThisWorkbook
    Set wf = WorksheetFunction
    Set objNewWorkbook = Excel.Application.Workbooks.Add
    Set objNewWorksheet = objNewWorkbook.Sheets(1)
    
    cntOtherTPNMerged = 0 'new counting item
    cntTPNLTG = 0 'new counting item
    cntMerged = 0
    cntNotMerged = 0
    MCBToFind = "MCB"
    MCCBToFind = "MCCB"
    
'new counting item
    With Application.FindFormat
        .WrapText = False
        .ShrinkToFit = False
        .MergeCells = True
    End With
    
    For i = 1 To ThisWorkbook.Sheets.Count
    
    Set sht = wb.Sheets(i)
    
    objNewWorksheet.Cells(i, 1) = sht.Name
    LastColumn = sht.Cells.Find("Remark", LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    
    Set rng = sht.Columns(LastColumn)
    Set foundOtherTPNCell = rng.Find(What:="*", after:=rng.Cells(1, 1), LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=True)
 'new counting item
 If Not foundOtherTPNCell Is Nothing Then
        FirstAddr = foundOtherTPNCell.Address
    End If
'new counting item
    Do Until foundOtherTPNCell Is Nothing
        If foundOtherTPNCell.MergeArea.Rows.Count = 3 And foundOtherTPNCell.Value <> "SPARE" And foundOtherTPNCell.Value <> "SPACE" Then
                cntOtherTPNMerged = cntOtherTPNMerged + 1
            Else
            If foundOtherTPNCell.MergeArea.Rows.Count = 3 And foundOtherTPNCell.Value = "*LIGHT*" Then
            cntTPNLTG = cntTPNLTG + 1
            End If
            
        End If
        

        Set foundOtherTPNCell = rng.Find(What:="*", after:=foundOtherTPNCell, SearchFormat:=True)

        
        If foundOtherTPNCell Is Nothing Then Exit Do
        If foundOtherTPNCell.Address = FirstAddr Then Exit Do
    Loop
      
Application.FindFormat.Clear
    
    
    
    Set foundMCB = rng.Find(What:=MCBToFind, after:=rng.Cells(1, 1), LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False)
        
    If Not foundMCB Is Nothing Then
        FirstAddr = foundMCB.Address
    End If
   
    Do Until foundMCB Is Nothing
        If foundMCB.MergeArea.Rows.Count = 3 Then
                cntMerged = cntMerged + 1
        Else
                cntNotMerged = cntNotMerged + 1
        End If
        

        Set foundMCB = rng.FindNext(after:=foundMCB)

        
        If foundMCB Is Nothing Then Exit Do
        If foundMCB.Address = FirstAddr Then Exit Do
    Loop
        
        Set foundMCCB = rng.Find(What:=MCCBToFind, after:=rng.Cells(1, 1), LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False)
        
         If Not foundMCCB Is Nothing Then
        FirstAddr = foundMCCB.Address
    End If
        
        Do Until foundMCCB Is Nothing
        If foundMCCB.MergeArea.Rows.Count = 3 Then
                cntMerged = cntMerged + 1
        Else
                cntNotMerged = cntNotMerged + 1
        End If
        

        Set foundMCCB = rng.FindNext(after:=foundMCCB)

        
        If foundMCCB Is Nothing Then Exit Do
        If foundMCCB.Address = FirstAddr Then Exit Do
    Loop
       
    objNewWorksheet.Cells(i, 8).Value = cntOtherTPNMerged - cntMerged - cntTPNLTG 'new counting item
    cntOtherTPNMerged = 0 'Reset to zero
    cntTPNLTG = 0 'Reset to zero
    objNewWorksheet.Cells(i, 2).Value = cntNotMerged
    cntNotMerged = 0 'Reset to zero
    objNewWorksheet.Cells(i, 3).Value = cntMerged
    cntMerged = 0 'Reset to zero
    
    objNewWorksheet.Cells(i, 4).Value = wf.CountIf(sht.Columns(LastColumn), "*S/O*")
    objNewWorksheet.Cells(i, 6).Value = _
    wf.CountIfs(sht.Columns(LastColumn), "*LTG*", sht.Columns(LastColumn), "<>*CONTACTOR*") + _
    wf.CountIfs(sht.Columns(LastColumn), "*SIGN BOX*", sht.Columns(LastColumn), "<>*CONTACTOR*") + _
    wf.CountIfs(sht.Columns(LastColumn), "*EXIT SIGN*", sht.Columns(LastColumn), "<>*CONTACTOR*") + _
    wf.CountIfs(sht.Columns(LastColumn), "*BOLLARD*", sht.Columns(LastColumn), "<>*CONTACTOR*") + _
    wf.CountIfs(sht.Columns(LastColumn), "*LIGHT*", sht.Columns(LastColumn), "<>*CONTACTOR*")
    rcdColumn = sht.Cells.Find("*RCD*", LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    objNewWorksheet.Cells(i, 5).Value = _
    wf.Count(sht.Columns(rcdColumn))
    
    Next i
    
        With objNewWorksheet
         .Rows(1).Insert
         .Cells(1, 1) = "NAME"
         .Cells(1, 1).Font.Bold = True
.Cells(1, 2) = "Submain SPN" 'DONE
.Cells(1, 3) = "Submain TPN" 'DONE
.Cells(1, 4) = "S/O" 'DONE
.Cells(1, 5) = "RCD/RCCB/RCBO" 'DONE
.Cells(1, 6) = "LTG." 'DONE
.Cells(1, 7) = "Other SPN" 'NOT DONE YET
.Cells(1, 8) = "Other TPN" 'NO DONE YET
.Columns("A:H").AutoFit
    End With
    
End Sub

Book54.xlsx

DB1 Contract No. : W.O. No. : Location : Description : Code of Distribution Board,Type of Distribution ,Main Switch,Distribution Board Location Circuit No. : 1,L1 L2 L3 2,L1 L2 L3 3,L1 L2 L3 4,L1 L2 L3 5,L1 L2 L3 6,L1 L2 L3 7,L1 L2 L3 8,L1 L2 L3 9,L1 9,L2 9,L3 10,L1 10,L2 10,L3 11,L1 L2 L3 12,...

docs.google.com