Fix Required - Find VBA - Specific Value

urubag

New Member
Joined
Aug 17, 2021
Messages
16
Office Version
  1. 365
Platform
  1. Windows
Hello Guys,

Please note I already have my code ready but I guess I have an issue with the order that macro is not moving on the next values as A.
The macro basically does validationS based on the cells in column E for all values that has "A", but my actual code is configured to stop when the cell is empty and I need the macro still running until last cell with "A".

VBA Code:
Sub FormatReport()

Application.ScreenUpdating = False

Dim strFirstAddress As String
Dim rngFindValue As Range
Dim rngSearch As Range
Dim rngFind As Range
Set rngFind = ActiveSheet.Range("E2:E1000000")
Set rngSearch = rngFind.Cells(rngFind.Cells.Count)
Set rngFindValue = rngFind.Find("A", rngSearch, xlValues)


Sheets("Temp to Submit").Select
Range("E2").Select

 If Not rngFindValue Is Nothing Then
 
   strFirstAddress = rngFindValue.Address
   
   Do
   
     Set rngFindValue = rngFind.FindNext(rngFindValue)
        
        If ActiveCell.Value = "A" Then
                        
                            ActiveCell.Offset(0, 4).Value = Date
                            ActiveCell.Offset(0, 5).Value = DateSerial(Year(Date), Month(Date) + 1, 1)
                            
                            If ActiveCell.Value = "A" And ActiveCell.Offset(0, -1).Value = "" Then
                            
                            
                                ActiveCell.Offset(0, -1).Interior.ColorIndex = 6
        
                            
                            End If
                        
                            If ActiveCell.Value = "A" And ActiveCell.Offset(0, 1).Value = "X" Or ActiveCell.Offset(0, 1).Value = "x" Then
                            
                            ActiveCell.Offset(0, -4).Select
                            Selection.Copy
                            
                            ActiveCell.Offset(0, 3).PasteSpecial xlPasteValues
                            ActiveCell.Interior.ColorIndex = 34
                            ActiveCell.Offset(0, 1).Select
                            
                            End If
                        
                            If ActiveCell.Value = "A" And ActiveCell.Offset(0, 2).Value = "X" And ActiveCell.Offset(0, -2).Value = "1000" Or ActiveCell.Offset(0, -2).Value = "1006" Then
                            
                                    ActiveCell.Offset(0, -1).Value = "10009999"
                                    ActiveCell.Offset(0, -1).Interior.ColorIndex = 34
                            
                               If ActiveCell.Value = "A" And ActiveCell.Offset(0, 2).Value = "X" And ActiveCell.Offset(0, -2).Value = "1010" Then
                            
                                    ActiveCell.Offset(0, -1).Value = "10109901"
                                    ActiveCell.Offset(0, -1).Interior.ColorIndex = 34
                                    
                                        
                                        If ActiveCell.Value = "A" And ActiveCell.Offset(0, 2).Value = "X" And ActiveCell.Offset(0, -2).Value = "1020" Then
                            
                                            ActiveCell.Offset(0, -1).Value = "10203005"
                                            ActiveCell.Offset(0, -1).Interior.ColorIndex = 34
                            
                                                    If ActiveCell.Value = "A" And ActiveCell.Offset(0, 2).Value = "X" And ActiveCell.Offset(0, -2).Value = "1022" Then
                            
                                                        ActiveCell.Offset(0, -1).Value = "10229001"
                                                        ActiveCell.Offset(0, -1).Interior.ColorIndex = 34
                            
                                                    End If
                               
                                
                                        End If
                            
                               End If
                               
 
                            End If
                            


        
            If ActiveCell.Value = "" Then
                
            End If
            
            ActiveCell.Offset(1, 0).Select
        End If
    
    
        
    Loop Until rngFindValue.Address = strFirstAddress
  
End If


End Sub

Guess I know what is the issue but not how to do it since I adapted a macro that I found in google about find values.

Thanks in advance
Andres
 

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes
Hi there

Please test below on a sample workbook (not your original data). I could not figure out what the other pieces of the code exactly does but seeing as you asked to to do all until the last A. I tested the below and with one click of the button it did the formatting with the dates and yellow as per attached image.

Screenshot 2022-09-01 204729.png

VBA Code:
Sub FormatReport()
    Application.ScreenUpdating = False
    Set fndRng = ActiveSheet.Range("E2:E1000000")
    Set rngFindValue = fndRng.Find(what:="A", Lookat:=xlWhole)
    If Not rngFindValue Is Nothing Then
        rngFirstAddress = rngFindValue.Address
        Do
            rngFindValue.Offset(0, 4).Value = Date
            rngFindValue.Offset(0, 5).Value = DateSerial(Year(Date), Month(Date) + 1, 1)
            rngFindValue.Offset(0, -1).Interior.ColorIndex = 6
            Set rngFindValue = fndRng.FindNext(rngFindValue)
        Loop Until rngFindValue Is Nothing Or rngFindValue.Address = rngFirstAddress
        If ActiveCell.Value = "A" And ActiveCell.Offset(0, 1).Value = "X" Or ActiveCell.Offset(0, 1).Value = "x" Then
            ActiveCell.Offset(0, -4).Select
            Selection.Copy
            ActiveCell.Offset(0, 3).PasteSpecial xlPasteValues
            ActiveCell.Interior.ColorIndex = 34
            ActiveCell.Offset(0, 1).Select
        End If
        If ActiveCell.Value = "A" And ActiveCell.Offset(0, 2).Value = "X" And ActiveCell.Offset(0, -2).Value = "1000" Or ActiveCell.Offset(0, -2).Value = "1006" Then
            ActiveCell.Offset(0, -1).Value = "10009999"
            ActiveCell.Offset(0, -1).Interior.ColorIndex = 34
            If ActiveCell.Value = "A" And ActiveCell.Offset(0, 2).Value = "X" And ActiveCell.Offset(0, -2).Value = "1010" Then
                ActiveCell.Offset(0, -1).Value = "10109901"
                ActiveCell.Offset(0, -1).Interior.ColorIndex = 34
                If ActiveCell.Value = "A" And ActiveCell.Offset(0, 2).Value = "X" And ActiveCell.Offset(0, -2).Value = "1020" Then
                    ActiveCell.Offset(0, -1).Value = "10203005"
                    ActiveCell.Offset(0, -1).Interior.ColorIndex = 34
                    If ActiveCell.Value = "A" And ActiveCell.Offset(0, 2).Value = "X" And ActiveCell.Offset(0, -2).Value = "1022" Then
                        ActiveCell.Offset(0, -1).Value = "10229001"
                        ActiveCell.Offset(0, -1).Interior.ColorIndex = 34
                    End If
                End If
            End If
        End If
    End If
End Sub
 
Upvote 0
Solution
Hi there

Please test below on a sample workbook (not your original data). I could not figure out what the other pieces of the code exactly does but seeing as you asked to to do all until the last A. I tested the below and with one click of the button it did the formatting with the dates and yellow as per attached image.

View attachment 73042

VBA Code:
Sub FormatReport()
    Application.ScreenUpdating = False
    Set fndRng = ActiveSheet.Range("E2:E1000000")
    Set rngFindValue = fndRng.Find(what:="A", Lookat:=xlWhole)
    If Not rngFindValue Is Nothing Then
        rngFirstAddress = rngFindValue.Address
        Do
            rngFindValue.Offset(0, 4).Value = Date
            rngFindValue.Offset(0, 5).Value = DateSerial(Year(Date), Month(Date) + 1, 1)
            rngFindValue.Offset(0, -1).Interior.ColorIndex = 6
            Set rngFindValue = fndRng.FindNext(rngFindValue)
        Loop Until rngFindValue Is Nothing Or rngFindValue.Address = rngFirstAddress
        If ActiveCell.Value = "A" And ActiveCell.Offset(0, 1).Value = "X" Or ActiveCell.Offset(0, 1).Value = "x" Then
            ActiveCell.Offset(0, -4).Select
            Selection.Copy
            ActiveCell.Offset(0, 3).PasteSpecial xlPasteValues
            ActiveCell.Interior.ColorIndex = 34
            ActiveCell.Offset(0, 1).Select
        End If
        If ActiveCell.Value = "A" And ActiveCell.Offset(0, 2).Value = "X" And ActiveCell.Offset(0, -2).Value = "1000" Or ActiveCell.Offset(0, -2).Value = "1006" Then
            ActiveCell.Offset(0, -1).Value = "10009999"
            ActiveCell.Offset(0, -1).Interior.ColorIndex = 34
            If ActiveCell.Value = "A" And ActiveCell.Offset(0, 2).Value = "X" And ActiveCell.Offset(0, -2).Value = "1010" Then
                ActiveCell.Offset(0, -1).Value = "10109901"
                ActiveCell.Offset(0, -1).Interior.ColorIndex = 34
                If ActiveCell.Value = "A" And ActiveCell.Offset(0, 2).Value = "X" And ActiveCell.Offset(0, -2).Value = "1020" Then
                    ActiveCell.Offset(0, -1).Value = "10203005"
                    ActiveCell.Offset(0, -1).Interior.ColorIndex = 34
                    If ActiveCell.Value = "A" And ActiveCell.Offset(0, 2).Value = "X" And ActiveCell.Offset(0, -2).Value = "1022" Then
                        ActiveCell.Offset(0, -1).Value = "10229001"
                        ActiveCell.Offset(0, -1).Interior.ColorIndex = 34
                    End If
                End If
            End If
        End If
    End If
End Sub

Let me check
 
Upvote 0
Hi there

Please test below on a sample workbook (not your original data). I could not figure out what the other pieces of the code exactly does but seeing as you asked to to do all until the last A. I tested the below and with one click of the button it did the formatting with the dates and yellow as per attached image.

View attachment 73042

VBA Code:
Sub FormatReport()
    Application.ScreenUpdating = False
    Set fndRng = ActiveSheet.Range("E2:E1000000")
    Set rngFindValue = fndRng.Find(what:="A", Lookat:=xlWhole)
    If Not rngFindValue Is Nothing Then
        rngFirstAddress = rngFindValue.Address
        Do
            rngFindValue.Offset(0, 4).Value = Date
            rngFindValue.Offset(0, 5).Value = DateSerial(Year(Date), Month(Date) + 1, 1)
            rngFindValue.Offset(0, -1).Interior.ColorIndex = 6
            Set rngFindValue = fndRng.FindNext(rngFindValue)
        Loop Until rngFindValue Is Nothing Or rngFindValue.Address = rngFirstAddress
        If ActiveCell.Value = "A" And ActiveCell.Offset(0, 1).Value = "X" Or ActiveCell.Offset(0, 1).Value = "x" Then
            ActiveCell.Offset(0, -4).Select
            Selection.Copy
            ActiveCell.Offset(0, 3).PasteSpecial xlPasteValues
            ActiveCell.Interior.ColorIndex = 34
            ActiveCell.Offset(0, 1).Select
        End If
        If ActiveCell.Value = "A" And ActiveCell.Offset(0, 2).Value = "X" And ActiveCell.Offset(0, -2).Value = "1000" Or ActiveCell.Offset(0, -2).Value = "1006" Then
            ActiveCell.Offset(0, -1).Value = "10009999"
            ActiveCell.Offset(0, -1).Interior.ColorIndex = 34
            If ActiveCell.Value = "A" And ActiveCell.Offset(0, 2).Value = "X" And ActiveCell.Offset(0, -2).Value = "1010" Then
                ActiveCell.Offset(0, -1).Value = "10109901"
                ActiveCell.Offset(0, -1).Interior.ColorIndex = 34
                If ActiveCell.Value = "A" And ActiveCell.Offset(0, 2).Value = "X" And ActiveCell.Offset(0, -2).Value = "1020" Then
                    ActiveCell.Offset(0, -1).Value = "10203005"
                    ActiveCell.Offset(0, -1).Interior.ColorIndex = 34
                    If ActiveCell.Value = "A" And ActiveCell.Offset(0, 2).Value = "X" And ActiveCell.Offset(0, -2).Value = "1022" Then
                        ActiveCell.Offset(0, -1).Value = "10229001"
                        ActiveCell.Offset(0, -1).Interior.ColorIndex = 34
                    End If
                End If
            End If
        End If
    End If
End Sub

I just added Range ("E2").select so activecell can start from that point but you know is perfect, thank you so much
 
Upvote 0
Glad to help and thanks for the feedback...
 
Upvote 0

Forum statistics

Threads
1,213,520
Messages
6,114,101
Members
448,548
Latest member
harryls

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top