CODEWITHSUNDEEP
vbaexcel
InternGrant
InternGrant

Reputation: 5

Error when copying row to another sheet

The code below brings up an error when trying to copy row over to new sheet. The excel sheet has 3 sheets, info (data export), filter(string names), results(blank sheet)

The code is supposed to match substring from filter worksheet with main string on info worksheet. If the substring is contained in the main string, it will copy the entire row over to the results worksheet. The error comes up when it's trying to copy over.

I could be overcomplicating the process, any help is greatly appreciated. Thanks in advance.

Error: Run-time error '1004': Application-defined or object-defined error

Sub RoundedRectangle1_Click()

Dim info As Range
Dim filter As Range
Dim results As Range

Set info = Worksheets("Info").Cells(4, 5)
Set filter = Worksheets("Filter").Cells(2, 1)
Set results = Worksheets("Results").Cells(1, 1)

Dim i, j, k As Integer

i = 0
j = 0
k = 0

Do While info.Offset(i, 0) <> ""

If InStr(1, LCase(info.Offset(i, 0)), LCase(filter.Offset(k, 0))) <> 0 Then
info.Offset(i, 0).EntireRow.Copy results.Cells(j, 1)
i = i + 1
j = j + 1
k = 0
Else
If filter.Offset(k, 0) = "" Then
i = i + 1
k = 0
Else
k = k + 1
End If
End If
Loop

End Sub

Upvotes: 0

Views: 86

Answers (2)

user3598756
user3598756

Reputation: 29421

if you don't mind the order of rows pasted into "Results" sheet you may want to try this:

Option Explicit

Sub main()
    Dim resultWS As Worksheet
    Dim subStrings As Variant, subString As Variant

    With Worksheets("Filter")
        subStrings = Application.Transpose(.Range("A2", .Cells(.Rows.count, 1).End(xlUp)))
    End With

    Set resultWS = Worksheets("Results")

    With Worksheets("Info")
        With .Range("E3", .Cells(.Rows.count, "E").End(xlUp))
            For Each subString In subStrings
                .AutoFilter field:=1, Criteria1:=subString
                If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then Intersect(.Resize(.Rows.count - 1).Offset(1).SpecialCells(xlCellTypeVisible).EntireRow, .Parent.UsedRange).Copy resultWS.Cells(.Rows.count, 1).End(xlUp).Offset(1)
            Next
        End With
        .AutoFilterMode = False
    End With
End Sub

Upvotes: 0

Brad
Brad

Reputation: 1480

This is happening because your var J is declared as 0. .Cells(0, 1) is a invalid cell. Adjust J's value to 1 to fix this.

Sub RoundedRectangle1_Click()

Dim info As Range
Dim filter As Range
Dim results As Range

Set info = Worksheets("Info").Cells(4, 5)
Set filter = Worksheets("Filter").Cells(2, 1)
Set results = Worksheets("Results").Cells(1, 1)

Dim i, j, k As Integer

i = 0
j = 1  'Error fixed here
k = 0

Do While info.Offset(i, 0) <> ""

If InStr(1, LCase(info.Offset(i, 0)), LCase(filter.Offset(k, 0))) <> 0 Then
info.Offset(i, 0).EntireRow.Copy results.Cells(j, 1)
i = i + 1
j = j + 1
k = 0
Else
If filter.Offset(k, 0) = "" Then
i = i + 1
k = 0
Else
k = k + 1
End If
End If
Loop

End Sub

Upvotes: 1

Related Questions