Better Code to Loop Through One Sheet, Spit Out Data in Other Sheet

[VBE313]

I have the following code that loops through Sheet1 Column J to find "TOP LEVEL" or "MAKE" and it Grabs the PART NUMBER. Then when LSR_01 appears, I need to paste the data in Sheet2 four times. So for every LSR_01, it needs to iterate four times on Sheet2 along with the most recent PART NUMBER. How can I write this code to be more efficient? I don't have any issues with the code I am just trying to improve my VBA skills.

Sub MrExcelTest()
Application.ScreenUpdating = False
Dim cl As Object, partNumber As String, lastRow As Long
    For Each cl In Sheets("Sheet1").Range("J:J")
        Select Case cl.Value
            Case "TOP LEVEL", "MAKE"
                partNumber = cl.Offset(0, -3).Value
            Case "LSR_01"
                Sheets("Sheet2").Activate
                lastRow = Cells(Rows.Count, 1).End(xlUp).Row
                Cells(lastRow, 1).Offset(1, 0).Select
                ActiveCell.Value = partNumber
                ActiveCell.Offset(1, 0).Value = partNumber
                ActiveCell.Offset(2, 0).Value = partNumber
                ActiveCell.Offset(3, 0).Value = partNumber
                ActiveCell.Offset(0, 1).Value = cl.Value
                ActiveCell.Offset(1, 1).Value = cl.Value
                ActiveCell.Offset(2, 1).Value = cl.Value
                ActiveCell.Offset(3, 1).Value = cl.Value
            Case ""
                Application.ScreenUpdating = True
                Exit Sub
            Case Else
        End Select
    Next cl
End Sub

Here is what the answer should look like.

 

[Norie]

This might be slightly more efficient.

Sub MrExcelTest()
Dim cl As Range, partNumber As String, lastRow As Long

    Application.ScreenUpdating = False

    For Each cl In Sheets("Sheet1").Range("J:J")
    
        Select Case cl.Value
            Case "TOP LEVEL", "MAKE"
                partNumber = cl.Offset(0, -3).Value
            Case "LSR_01"
                With Sheets("Sheet2")
                    lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
                    .Cells(lastRow, 1).Offset(1, 0).Resize(4).Value = partNumber
                    .Cells(lastRow, 1).Offset(1, 1).Resize(4).Value = cl.Value
                End With
            Case ""
                Application.ScreenUpdating = True
                Exit Sub
            Case Else
        End Select
        
    Next cl
    
End Sub

 

[VBE313]

This might be slightly more efficient.

Sub MrExcelTest()
Dim cl As Range, partNumber As String, lastRow As Long

    Application.ScreenUpdating = False

    For Each cl In Sheets("Sheet1").Range("J:J")
   
        Select Case cl.Value
            Case "TOP LEVEL", "MAKE"
                partNumber = cl.Offset(0, -3).Value
            Case "LSR_01"
                With Sheets("Sheet2")
                    lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
                    .Cells(lastRow, 1).Offset(1, 0).Resize(4).Value = partNumber
                    .Cells(lastRow, 1).Offset(1, 1).Resize(4).Value = cl.Value
                End With
            Case ""
                Application.ScreenUpdating = True
                Exit Sub
            Case Else
        End Select
       
    Next cl
   
End Sub

This is definitely more efficient. Thank you!

 

[Fluff]

How about

Sub MrExcelTest()
   Application.ScreenUpdating = False
   Dim cl As Object, partNumber As String, lastRow As Long
   
   With Sheets("Sheet2")
      For Each cl In Sheets("Sheet1").Range("J1:J" & Rows.Count).End(xlUp)
         Select Case cl.Value
            Case "TOP LEVEL", "MAKE"
               partNumber = cl.Offset(0, -3).Value
            Case "LSR_01"
               lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
               .Cells(lastRow, 1).Offset(1, 0).Resize(4, 2).Value = Array(partNumber, cl.Value)
         End Select
      Next cl
   End With
End Sub

 

[VBE313]

How about

Sub MrExcelTest()
   Application.ScreenUpdating = False
   Dim cl As Object, partNumber As String, lastRow As Long
  
   With Sheets("Sheet2")
      For Each cl In Sheets("Sheet1").Range("J1:J" & Rows.Count).End(xlUp)
         Select Case cl.Value
            Case "TOP LEVEL", "MAKE"
               partNumber = cl.Offset(0, -3).Value
            Case "LSR_01"
               lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
               .Cells(lastRow, 1).Offset(1, 0).Resize(4, 2).Value = Array(partNumber, cl.Value)
         End Select
      Next cl
   End With
End Sub

Thank you! I like how it does both at the same time!

 

[Fluff]

You're welcome & thanks for the feedback