VBA Help - Rewrite my Loop in a different order

Johnny Thunder

Well-known Member
Joined
Apr 9, 2010
Messages
693
Office Version
  1. 2016
Platform
  1. MacOS
Hello All,


Need some help with my loop code, currently it works great for the first loop, the issue I am having is that I am using a .Find Method to search a column for a value (Currently working great) problem is that once I Declare the found variable the code process a few updates based on that found value but then in the event there is more than one instance of that found value I need my code to start over again with the next instance of that found value. I have all the pieces of the puzzle working just not in the correct order and I am unable to think of a way to correct this. Any help is appreciated!

Code:
Set ws2 = Sheets("Form")
    LastR3 = ws2.Cells(Rows.Count, "A").End(xlUp).Row


PrjCount = Application.WorksheetFunction.CountIf(FoundSht.Range("C10:C" & LastR2), Project) 'Counts all the occurences of my Value - Will be used to determine how many times to do the loop
Timestamp = Format(CStr(Now), "mm/dd/yyyy hh:mmam/pm")
    
    For i = 1 To PrjCount   'Defines how many times to do the loop of in the event there is more than 1 Project Found
            
           ws2.Range("H1").Value = i 'I have code that makes a copy of the Form Sheet and Timestamps the file and appends the Searched Value as the Filename - In the event of duplicates this will make each file unique
            
            '----------------------Provides Loop to Search for Project in Column C----------------------
            With FoundSht.Range("C10:C" & LastR3)
                Set LastCell = .Cells(.Cells.Count)
            End With
            Set Foundcell = FoundSht.Range("C10:C" & LastR3).Find(what:=Project, after:=LastCell) 'Gets my Search Value for the 1st time
            
            If Not Foundcell Is Nothing Then
                FirstAddr = Foundcell.Address
                End If
                
                Do Until Foundcell Is Nothing
                FoundSht.Range("C" & Foundcell.Row & ":" & LastCL2 & Foundcell.Row).Copy 'Copies my found value and pastes it into a seperate sheet "Form"
                ws2.Range("G5").PasteSpecial xlValues, Transpose:=True
                
            '----------------------Provides Loop to Search for Project in Column C----------------------
                         With ws2
                            .Range("B5:H" & LastR3).ClearContents   'Clears old data before start
                                .Range("C1").Value = Project   'Applies Poject Name in Header
                                    .Range("B2").Value = "Type: " & SrchSht      'Applies Poject Name in Header
                                        .Range("H2").Value = Timestamp  'Applies Time Stamp in header
                            
                            FoundSht.Range("C4:" & LastCL2 & "4").Copy  'Copies Category
                                .Range("B5").PasteSpecial xlValues, Transpose:=True
                        
                            FoundSht.Range("C6:" & LastCL2 & "6").Copy  'Copies Attribute
                                .Range("C5").PasteSpecial xlValues, Transpose:=True
                                
                            FoundSht.Range("C7:" & LastCL2 & "7").Copy  'Copies Field Type
                                .Range("D5").PasteSpecial xlValues, Transpose:=True
                                
                            FoundSht.Range("C8:" & LastCL2 & "8").Copy  'Copies Selection Options
                                .Range("E5").PasteSpecial xlValues, Transpose:=True
                                
                            FoundSht.Range("C9:" & LastCL2 & "9").Copy  'Copies Data Source
                                .Range("F5").PasteSpecial xlValues, Transpose:=True
                         End With
                            
                Call SaveSheet  ' Creates Copy of Sheet and Sets Print Details                
               
                Set Foundcell = FoundSht.Range("C10:C" & LastR3).FindNext(after:=Foundcell)  '<-----------------------------Here is one of the problems, this will continue the search to see if there is another Value within the range - If found, I need it to go back to the Start of the Clear Contents code to run through that whole block again


                If Foundcell.Address = FirstAddr Then
                    Exit Do 'If no other values are found exit this loop
                End If
            Loop
            '----------------------Provides Loop to Search for Project in Column C----------------------
        
    
    Next i 'Continues the overall loop - May be redundant
 
Last edited:

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"
Not tested, because it is not all the code and I do not see several variables and sheets.

You only need one loop.


Code:
  Dim i As Long
  i = 1
  Set WS2 = Sheets("Form")
  Timestamp = Format(CStr(Now), "mm/dd/yyyy hh:mmam/pm")
  LastR3 = FoundSht.Cells(Rows.Count, "C").End(xlUp).Row 'column C, Because it is the search column
  Set Foundcell = FoundSht.Range("C10:C" & LastR3).Find(Project, , xlValues, xlWhole)  'Gets my Search Value for the 1st time
  If Not Foundcell Is Nothing Then
    FirstAddr = Foundcell.Address
[COLOR=#0000ff]    Do Until Foundcell Is Nothing[/COLOR]
      WS2.Range("H1").Value = i
      i = i + 1
      FoundSht.Range("C" & Foundcell.Row & ":" & LastCL2 & Foundcell.Row).Copy 'Copies my found value and pastes it into a seperate sheet "Form"
      WS2.Range("G5").PasteSpecial xlValues, Transpose:=True
      WS2.Range("B5:H" & LastR3).ClearContents   'Clears old data before start
      WS2.Range("C1").Value = Project   'Applies Poject Name in Header
      WS2.Range("B2").Value = "Type: " & SrchSht      'Applies Poject Name in Header
      WS2.Range("H2").Value = Timestamp  'Applies Time Stamp in header
      FoundSht.Range("C4:" & LastCL2 & "4").Copy  'Copies Category
      WS2.Range("B5").PasteSpecial xlValues, Transpose:=True
      FoundSht.Range("C6:" & LastCL2 & "6").Copy  'Copies Attribute
      WS2.Range("C5").PasteSpecial xlValues, Transpose:=True
      FoundSht.Range("C7:" & LastCL2 & "7").Copy  'Copies Field Type
      WS2.Range("D5").PasteSpecial xlValues, Transpose:=True
      FoundSht.Range("C8:" & LastCL2 & "8").Copy  'Copies Selection Options
      WS2.Range("E5").PasteSpecial xlValues, Transpose:=True
      FoundSht.Range("C9:" & LastCL2 & "9").Copy  'Copies Data Source
      WS2.Range("F5").PasteSpecial xlValues, Transpose:=True
      
      Call SaveSheet  ' Creates Copy of Sheet and Sets Print Details
      Set Foundcell = FoundSht.Range("C10:C" & LastR3).FindNext(Foundcell)
[COLOR=#0000ff]    Loop While Not Foundcell Is Nothing And Foundcell.Address <> FirstAddr[/COLOR]
  End If
 
Upvote 0
I'm glad to help you. Thanks for the feedback.
 
Upvote 0

Forum statistics

Threads
1,213,494
Messages
6,113,986
Members
448,538
Latest member
alex78

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