Copy and paste data to separate sheets based on mutiple criteria again

I had a problem solved for me previously here. However, I now have additional data that needs to be copied over to a new sheet. This data includes blank cells.

I embedded an If statement to help fix the issue, but it doesn't seem to work.

For Each iCell In wsData.Range("A" & CurrentItem & ":L" & CurrentItem)
    Dim rngNextLine As Range:   Set rngNextLine = wsDest.Cells(Rows.Count, iCell.Column).End(xlUp).Offset(1, 0)
        If iCell.Value = "" Then
        rngNextLine.Value = ""
        Else
        rngNextLine.Value = iCell.Value
        End If
Next iCell

Can anyone tell me what I'm doing wrong? I've attached my sample.

Hello Ricker090,

It would help to know what the expected outcome looks like.

Hello Ricker090,

Thanks for doing that. I didn't mean for you do that much work. Just a few sheets would have been fine.

Hello Ricker090,

Sorry for the delay. I have rewrote the macro to be more flexible and faster. A button has been added to "Sheet1" to run the macro. Here is the revised macro code...

Sub MoveData_1()

  Dim DataTitle As String
  Dim DstWks As Worksheet
  Dim Headers As Range
  Dim NextRow As Range
  Dim R As Long
  Dim Rng As Range
  Dim RngEnd As Range
  Dim SrcWks As Worksheet
  
    Set SrcWks = Worksheets("Master Data")
    
    Set Headers = SrcWks.UsedRange.Rows(1)
    
    Set Rng = Headers.Offset(1, 0)
    Set RngEnd = SrcWks.Cells(Rows.Count, Rng.Column).End(xlUp)
    Set Rng = SrcWks.Range(Rng, RngEnd)
    
    Application.ScreenUpdating = False
    
      For R = 1 To Rng.Rows.Count
        DataTitle = Rng.Item(R, 1) & Rng.Item(R, 2) & Rng.Item(R, 3)
        
        If DataTitle <> SrcWks.Name Then
           On Error Resume Next
           Set DstWks = Worksheets(DataTitle)
             If Err <> 0 Then
                Worksheets.Add After:=Worksheets(Worksheets.Count)
                ActiveSheet.Name = DataTitle
                Set DstWks = ActiveSheet
                Err.Clear
             End If
           On Error GoTo 0
           
           Set NextRow = DstWks.Cells(Rows.Count, "A").End(xlUp)
             If NextRow.Row = 1 And NextRow = "" Then
                Headers.Copy NextRow
             End If
           
           Set NextRow = NextRow.Offset(1, 0)
           Rng.Rows(R).Copy NextRow
        End If
      Next R
    
    Application.ScreenUpdating = True

End Sub

Hello Ricker090,

Change the NextRow number from 1 to 7...

           Set NextRow = DstWks.Cells(Rows.Count, "A").End(xlUp)
            If NextRow.Row = 7 And NextRow = "" Then
                Headers.Copy NextRow
            End If

Hello Ricker090,

I changed the macro to start at "A7" on the individual destination sheets. The macro has been tested and works. Replace your old macro with this code.

Sub MoveData_1a()

  Dim DataTitle As String
  Dim DstRng As Range
  Dim DstWks As Worksheet
  Dim Headers As Range
  Dim NextRow As Range
  Dim R As Long
  Dim Rng As Range
  Dim RngEnd As Range
  Dim SrcWks As Worksheet
  
    Set SrcWks = Worksheets("Master Data")
    
    Set Headers = SrcWks.UsedRange.Rows(1)
    
    Set Rng = Headers.Offset(1, 0)
    Set RngEnd = SrcWks.Cells(Rows.Count, Rng.Column).End(xlUp)
    Set Rng = SrcWks.Range(Rng, RngEnd)
    
    Application.ScreenUpdating = False
    
      For R = 1 To Rng.Rows.Count
        DataTitle = Rng.Item(R, 1) & Rng.Item(R, 2) & Rng.Item(R, 3)
        
        If DataTitle <> SrcWks.Name Then
           On Error Resume Next
           Set DstWks = Worksheets(DataTitle)
             If Err <> 0 Then
                Worksheets.Add After:=Worksheets(Worksheets.Count)
                ActiveSheet.Name = DataTitle
                Set DstWks = ActiveSheet
                Err.Clear
             End If
           On Error GoTo 0
           
           Set DstRng = DstWks.Range("A7")
           Set NextRow = DstWks.Cells(Rows.Count, "A").End(xlUp)
           
             If NextRow.Row < DstRng.Row Then
                Set NextRow = DstWks.Range("A7")
                Headers.Copy NextRow
             End If
           
           Set NextRow = NextRow.Offset(1, 0)
           Rng.Rows(R).Copy NextRow
        End If
      Next R
    
    Application.ScreenUpdating = True

End Sub