Fix Required - Find VBA - Specific Value

U

urubag

New Member
Joined
Aug 17, 2021
Messages
20
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

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.
Sort by date Sort by votes
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
Jimmypop said:
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
Click to expand...

Let me check
 
Upvote 0
Jimmypop said:
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
Click to expand...

I just added Range ("E2").select so activecell can start from that point but you know is perfect, thank you so much
 
Upvote 0
You must log in or register to reply here.

Similar threads

W
  • Question Question
VBA InputBox without entry quitting Sub/Macro
Replies
1
Views
542
Micron
M
Rhodie72
  • Question Question
How to write a data to a text file (VBA)
2
Replies
17
Views
1K
Rhodie72
Rhodie72
S
  • Solved
VBA: reference a cell value in a different worksheet with alternative worksheet
Replies
7
Views
324
Peter_SSs
Peter_SSs
S
  • Question Question
VBA Duplicates
Replies
1
Views
373
Alex Blakenburg
A
U
  • Question Question
Text Value from Textbox to Integer
Replies
1
Views
333
Kaper
Kaper

Forum statistics

Threads
1,223,900
Messages
6,175,276
Members
452,629
Latest member
SahilPolekar

Share this page

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