Need to Apply LOOP for this code

[Deepak Sharma]

Hi Everyone,

I need to apply a loop for my attached file Code. Please see how can I do this.

Actually I need to find "Agent:-" in column "A" then again find this in same row then copy all the rows inbetween those two FOUND Results and paste in diff file and again start the same concept from where it LEFT After Second found result.

Or is there any OTHER SOLUTION to do this copy/paste for these certain rows. Because I found this Idea better, so coded accordingly.

Please see the attached file and code.

Thanks and Regards,
Deepak

 

[Hui]

I would use Range.Find and then Range.Findnext
Cut the rows to a new workbook & save new workbook
Repeat until there is none more found

Don't have time to do now

 

[Deepak Sharma]

Hi Hui, Thanks for your time but Actually this is my just beginning in VBA & also not clear with Looping concepts, That's don't know how to do it.

If anyone ELSE could do it please.

Regards,

 

[Marc L]

Hi !

Where is the result attachment ?

See also the VBA inner help for any concept …
​

 

[Hui]

Try this code

Sub find_paste()

Dim path As String, filename As String
Dim rng As Excel.Range
Dim lr As Long, fr As Long

Application.ScreenUpdating = False

' Search for the First Cell

fr = 1
lr = Range("A" & Rows.Count).Row

On Error GoTo err

Do
  'Goto first cell of next search range
  Range("A" & CStr(fr)).Select
  Set rng = Range("A" & CStr(fr) & ":A" & CStr(lr))
 
  'Find first row
  rng.Find(What:="agent:", _
          After:=ActiveCell, _
          LookIn:=xlFormulas, _
          LookAt:=xlPart, _
          SearchOrder:=xlByRows, _
          SearchDirection:=xlNext, _
          MatchCase:=False, _
          SearchFormat:=False).Activate
 
  fr = ActiveCell.Row
 
  'Find second row
  Dim sr As Long
  sr = rng.FindNext(After:=ActiveCell).Row
 
  'COPY\PASTE DATA & SAVE\CLOSE THE FILE
  Range("A" & CStr(fr), "P" & CStr(sr)).Copy
  Workbooks.Add
  ActiveWorkbook.Sheets("Sheet1").Range("A1").PasteSpecial
  Columns.AutoFit
  Range("A2").Select
  ActiveCell.FormulaR1C1 = "=RIGHT(R1C1,LEN(R1C1)-FIND("" "",R1C1))"
  path = "C:\Users\deepaksharma\Desktop\" 'deepaksharma
  filename = Range("A2").Text
  ActiveWorkbook.SaveAs filename:=path & filename & ".xlsx", FileFormat:=51
  ActiveWorkbook.ActiveSheet.Range("A2").ClearContents
  ActiveWorkbook.Close savechanges:=True
       
  'set up next range
  fr = sr + 1
Loop

err:

Application.ScreenUpdating = True

End Sub

 

[Deepak Sharma]

Thank you so so much Hui !! That's what exactly I was looking for. You have also changed the lookup column i.e. "A", Thats very right because I was using cells.find which could find anywhere on sheet, But you did exactly right to make it search in A Col. only.
Thank you once again Dear !!!

 

[Marc L]

As a beginner starter :​

Sub Demo1()
         Const S = "Agent:- "
           Dim Rg(1) As Range, F$, R&
           If Workbooks.Count > 1 Then Beep: Exit Sub
    With Sheet1.UsedRange.Rows
           Set Rg(0) = .Columns(1).Find(S & "*", .Cells(1), xlValues, xlWhole)
        If Not Rg(0) Is Nothing Then
                F = ThisWorkbook.Path & "\"
                Application.DisplayAlerts = False
                Application.ScreenUpdating = False
                Workbooks.Add
              Set Rg(1) = .Columns(1).FindNext(Rg(0))
            While Rg(1).Row > R
               .Item(Rg(0).Row & ":" & Rg(1).Row).Copy
                [A1].PasteSpecial xlPasteFormats
                [A1].PasteSpecial xlPasteValues
                ActiveSheet.UsedRange.Columns.AutoFit
                ActiveWorkbook.SaveAs F & Split(Rg(0).Value, S)(1) & " .xlsx", 51
                ActiveSheet.UsedRange.Clear
                R = Rg(1).Row
                Set Rg(0) = .Columns(1).FindNext(Rg(1))
                Set Rg(1) = .Columns(1).FindNext(Rg(0))
            Wend
                Erase Rg
                ActiveWorkbook.Close False
                Application.DisplayAlerts = True
                Application.ScreenUpdating = True
        End If
    End With
End Sub

Do you like it ? So thanks to click on bottom right Like !
​