Offset not working correctly

[Francois084]

Hi

I'm having trouble with my offset
I used my previous code and changed it so that it look for a specific word and search over multiple worksheets
It does find the word and copies it over to the new sheet.
but when it find the 2nd one it overwrites the previous line on the new sheet

Thank you for helping

Sub OtherSearchString()

Dim iIndex As Integer
Dim ws As Excel.Worksheet
Dim lr As Long
Dim r As Long
Dim C As Range
Dim Target As Worksheet
b = 0
Set Target = ActiveWorkbook.Worksheets("Supp or Dept")

    For iIndex = 1 To ActiveWorkbook.Worksheets.Count
        Set ws = Worksheets(iIndex)
        ws.Activate
        '   Find last row in column E on Source sheet
    lr = ws.Cells(Rows.Count, "C").End(xlUp).Row

'   Loop through each row in column E backwards
    For r = lr To 1 Step -1
'       Build "c" range
        Set C = ws.Range("C" & r)
'       Proceed with rest of your code
        If C Like "*SUPP*" Then
            C.EntireRow.copy
            Target.Range("A" & Rows.Count).End(xlDown).Offset(1).PasteSpecial
            C.EntireRow.Delete
        ElseIf C Like "*DEPT*" Then
            C.EntireRow.copy
            b = Target.Range("A" & Rows.Count).End(xlUp).Offset(3).PasteSpecial
            b = b + 1
            C.EntireRow.Delete
            
        End If
    Next r
Next iIndex
End Sub

 

[mumps]

I am confused by this line of code:

b = Target.Range("A" & Rows.Count).End(xlUp).Offset(3).PasteSpecial

What does the variable "b" represent? Why Offset(3) instead of Offset(1)?
It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of one of your sheets. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

 

[Francois084]

Sorry

I was trying different things to get to the next line
here is the clean code

Sub OtherSearchString()

Dim iIndex As Integer
Dim ws As Excel.Worksheet
Dim lr As Long
Dim r As Long
Dim C As Range
Dim Target As Worksheet
Set Target = ActiveWorkbook.Worksheets("Supp or Dept")

    For iIndex = 1 To ActiveWorkbook.Worksheets.Count
        Set ws = Worksheets(iIndex)
        ws.Activate
        '   Find last row in column E on Source sheet
    lr = ws.Cells(Rows.Count, "C").End(xlUp).Row

'   Loop through each row in column E backwards
    For r = lr To 1 Step -1
'       Build "c" range
        Set C = ws.Range("C" & r)
'       Proceed with rest of your code
        If C Like "*SUPP*" Then
            C.EntireRow.copy
            Target.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial
            C.EntireRow.Delete
        ElseIf C Like "*DEPT*" Then
            C.EntireRow.copy
            Target.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial
            C.EntireRow.Delete
            
        End If
    Next r
Next iIndex
End Sub

 

[mumps]

This macro assumes that you have headers in row 1 and your data starts in row 2.

Sub OtherSearchString()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet
    Set desWS = Sheets("Supp or Dept")
    For Each ws In Sheets
        If ws.Name <> "Supp or Dept" Then
            With ws
                .Range("A1").AutoFilter 3, Criteria1:="*SUPP*", Operator:=xlOr, Criteria2:="*DEPT*"
                .AutoFilter.Range.Offset(1).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1)
                .AutoFilter.Range.Offset(1).EntireRow.Delete
                .Range("A1").AutoFilter
            End With
        End If
    Next ws
    Application.ScreenUpdating = True
End Sub

 

[Francois084]

Hi. it works but it pulls in extra data

Item 1

Item 2

Item 3

Item 4

Item 5

SUPPLIER 1

SUPPLIER 2

SUPPLIER 3

SUPPLIER 4

Item 2

Item 3

Item 4

Item 6

Item 1

Item 2

Item 3

Item 4

Item 5

SUPPLIER 1

SUPPLIER 2

SUPPLIER 3

SUPPLIER 4

Item 2

Item 3

Item 4

Item 6

 

[mumps]

Please refer to Post #2 to attach a screen shot or file.

 

[Francois084]

 

[mumps]

It is hard to work with a picture. Please use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of the entire sheet with the row numbers and column letters visible or upload a copy of your file to a free site such as www.box.com or www.dropbox.com and post the link to the file.

 

[Francois084]

BigPromo.xlsx
	A	B	C
1
2	703117009	6009675630035	Item 1
3	198691	6009695583441	Item 2
4	162159	6009695581867	Item 3
5	701794002	6005111002909	Item 4
6	257730	6009516204630	Item 5
7			SUPPLIER 1
8			SUPPLIER 2
9			SUPPLIER 3
10			SUPPLIER 4
11	198691	6009695583441	Item 2
12	162159	6009695581867	Item 3
13	701794002	6005111002909	Item 4
14	164695	6009802884294	Item 6
15	703117009	6009675630035	Item 1
16	198691	6009695583441	Item 2
17	162159	6009695581867	Item 3
18	701794002	6005111002909	Item 4
19	257730	6009516204630	Item 5
20			SUPPLIER 1
21			SUPPLIER 2
22			SUPPLIER 3
23			SUPPLIER 4
24	198691	6009695583441	Item 2
25	162159	6009695581867	Item 3
26	701794002	6005111002909	Item 4
27	164695	6009802884294	Item 6
28
29
Supp or Dept

 

[Francois084]

The Sub SearchString() work 100%. copies every line to the new sheet, new line
but the Sub OtherSearchString() does not make a new line on the new sheet

Sub SearchString()

Dim lr As Long
Dim r As Long
Dim C As Range
Dim Source As Worksheet
Dim Target As Worksheet
Dim Target1 As Worksheet

Set Source = ActiveWorkbook.Worksheets("Master List")
Set Target = ActiveWorkbook.Worksheets("Group")
  
'   Find last row in column E on Source sheet
    lr = Source.Cells(Rows.Count, "E").End(xlUp).Row

'   Loop through each row in column E backwards
    For r = lr To 1 Step -1
'       Build "c" range
        Set C = Source.Range("E" & r)
'       Proceed with rest of your code
        If C Like "*FOR*" Then
            C.EntireRow.copy
            Target.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
            C.EntireRow.Delete
        ElseIf C Like "*+*" Then
            C.EntireRow.copy
            Target.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
            C.EntireRow.Delete
        End If
    Next r
    Columns("A:A").NumberFormat = "#"
    Columns("B:B").NumberFormat = "#"
Sheets.Add.Name = "Supp or Dept"
 Worksheets("Supp or Dept").Move After:=Worksheets(Worksheets.Count)
Call OtherSearchString
End Sub
Sub OtherSearchString()

Dim lr As Long
Dim r As Long
Dim C As Range
Dim Source As Worksheet
Dim Target As Worksheet
Dim Target1 As Worksheet

Set Source = ActiveWorkbook.Worksheets("Master List")
Set Target = ActiveWorkbook.Worksheets("Supp or Dept")
  
'   Find last row in column E on Source sheet
    lr = Source.Cells(Rows.Count, "C").End(xlUp).Row

'   Loop through each row in column E backwards
    For r = lr To 1 Step -1
'       Build "c" range
        Set C = Source.Range("C" & r)
'       Proceed with rest of your code
        If C Like "*SUPP*" Then
            C.EntireRow.copy
            Target.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
            C.EntireRow.Delete
        ElseIf C Like "*DEPT*" Then
            C.EntireRow.copy
            Target.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
            C.EntireRow.Delete
        End If
    Next r
End Sub