VBA Help - Rewrite my Loop in a different order

[Johnny Thunder]

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!

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

 

[DanteAmor]

Not tested, because it is not all the code and I do not see several variables and sheets.

You only need one loop.

  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

 

[Johnny Thunder]

That worked great! Thanks!

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.