Copy and Paste based on cell value

[Rogerisit]

Hi

Part 2 of this isn't working (For i = 2 to last row on) I'm trying to copy and paste relevant cells from each row that is the same as MyCell value which is what I have named each new tab.

  For Each MyCell In MyRange
        Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
        Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet
    Next MyCell
  
    lastrow = ws.Range("a" & Rows.Count).End(xlUp).Row
  
    For i = 2 To lastrow
        If ws.Range("d2:d") = MyCell.Value And _
        ws.Range("d2:d").Offset(1, 0) <> "Miscellaneous" _
        And ws.Range("d2:d").Offset(5, 0) <> "" Then
        ws.Range("A" & i & ":F" & i & ",G" & i & ":H" & i).Copy
        On Error Resume Next
    Sheets(MyCell.Value).Select
    ActiveSheet.PasteSpecial Paste:=xlPasteValues
        End If
    Next i

Any help welcome thanks.

 

[DanteAmor]

Hello @Rogerisit

It's not clear to me what you're trying to do. You didn't put your entire macro, so we have to assume a few things.
You also didn't put examples of what you have in your sheets, what you have in MyRange and what you expect as a result.

Without that information it is very risky to give you a complete solution. But I will take the risk because I am an adventurer.

Replace all your code, at least what you put, with the following:

  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
 
  For Each MyCell In MyRange
    On Error Resume Next: Sheets(MyCell.Value).Delete: On Error GoTo 0
    Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
    Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet
   
    For i = 2 To ws.Range("A" & Rows.Count).End(xlUp).Row
      If ws.Range("D" & i).Value = MyCell.Value And _
         ws.Range("D" & i).Offset(1, 0) <> "Miscellaneous" And _
         ws.Range("D" & i).Offset(5, 0) <> "" Then

        ws.Range("A" & i & ":H" & i).Copy
        With Sheets(MyCell.Value)
          lr2 = .Range("A" & Rows.Count).End(xlUp).Row + 1
          .Range("A" & lr2).PasteSpecial Paste:=xlPasteValues
        End With

      End If
    Next i
  Next MyCell
 
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​

 

[jolivanes]

If you have a problem with ranges you set not working out, you can put that range into a short macro like so

Sub Test()
Range("D2:D").Select
End Sub

and run it. You'll see that it errors so fix that and see what happens.

 

[Rogerisit]

Hello @Rogerisit

It's not clear to me what you're trying to do. You didn't put your entire macro, so we have to assume a few things.
You also didn't put examples of what you have in your sheets, what you have in MyRange and what you expect as a result.

Without that information it is very risky to give you a complete solution. But I will take the risk because I am an adventurer.

Replace all your code, at least what you put, with the following:

  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
 
  For Each MyCell In MyRange
    On Error Resume Next: Sheets(MyCell.Value).Delete: On Error GoTo 0
    Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
    Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet
  
    For i = 2 To ws.Range("A" & Rows.Count).End(xlUp).Row
      If ws.Range("D" & i).Value = MyCell.Value And _
         ws.Range("D" & i).Offset(1, 0) <> "Miscellaneous" And _
         ws.Range("D" & i).Offset(5, 0) <> "" Then

        ws.Range("A" & i & ":H" & i).Copy
        With Sheets(MyCell.Value)
          lr2 = .Range("A" & Rows.Count).End(xlUp).Row + 1
          .Range("A" & lr2).PasteSpecial Paste:=xlPasteValues
        End With

      End If
    Next i
  Next MyCell
 
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​

Sorry for lack of info, but it seems you can read my mind. Thanks very much.