CODEWITHSUNDEEP
vbaexcel
Mikz
Mikz

Reputation: 591

Copying from one workbook to another if it matches the criteria

I am trying to copy rows that satisfymy criteria from one workbook to another.

In my Workbook1, I want to look for 8TH Column, and if it has "TRU", then I would like to copy the entire to another new workbook with sheet name "Pivottable" and save it under .xlsx format.

I have tried the below code so far, but I am getting the error

Subscript Out of Range

Sub OpenBook()
    Dim MyBook As Workbook, newBook As Workbook
    Dim FileNm As String
    Dim LastRow As Long
    Dim i As Long, j As Long

    Set MyBook = ThisWorkbook

    FileNm = ThisWorkbook.Path & "\" & "ProjectList.xlsx"
    Set newBook = Workbooks.Add

    With MyBook
    With Worksheets("Pivottabelle")
      LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
   End With
   End With

    With newBook
    Sheets("Sheet1").Name = "PivotTable"
    With Worksheets("PivotTable")
      j = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
   End With
   End With

   With newBook
   For i = 1 To LastRow
       With Worksheets("Pivottabelle")
           If .Cells(i, 8).Value = "TRU" Then
               .Rows(i).Copy Destination:=Worksheets("PivotTable").Range("A" & j)
               j = j + 1
           End If
       End With
   Next i

        'Save new wb with XLS extension
        .SaveAs Filename:=FileNm, FileFormat:=xlNormal, CreateBackup:=True

        .Close Savechanges:=False
    End With
End Sub

Edit: Error dialogue box enter image description here

Upvotes: 0

Views: 42

Answers (1)

CLR
CLR

Reputation: 12279

Wow, there is a lot of use of With and End With here, without actually getting the benefit of it.

I've gone through the code and fixed it where I think it needed it but you might want to check that my interpretation is correct:

Dim FileNm As String
Dim LastRow As Long
Dim i As Long, j As Long

Set MyBook = ThisWorkbook

FileNm = MyBook.Path & "\" & "ProjectList.xlsx"
Set newBook = Workbooks.Add

With MyBook.Worksheets("Pivottabelle")
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

With newBook.Sheets("Sheet1")
    .Name = "PivotTable"
    j = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With

With MyBook.Worksheets("Pivottabelle")
    For i = 1 To LastRow
        If .Cells(i, 8).Value = "TRU" Then
            .Rows(i).Copy Destination:=newBook.Worksheets("PivotTable").Range("A" & j)
            j = j + 1
        End If
    Next i
End With

With newBook
    'Save new wb with XLS extension
    .SaveAs Filename:=FileNm, FileFormat:=xlNormal, CreateBackup:=True
    .Close Savechanges:=False
End With

Upvotes: 1

Related Questions