Updating VBA Code Help

[cmschmitz24]

Hello,

Can someone please help with updating an old code.
What the code is trying to do is take values in column B and copy/paste them on a new sheet.
Column B can have multiple lines with different information, but the values in column B will always be the same.

Dim LastCol As Integer, i As Long, iStart As Long, iEnd As Long
    Dim ws As Worksheet
    Application.ScreenUpdating = False
    With ActiveSheet
    lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
    LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    
    iStart = 2
    For i = 2 To lastrow
        If .Range("B" & i).Value <> .Range("B" & i + 1).Value Then
            iEnd = i
            Sheets.Add after:=Sheets(Sheets.Count)
            Set ws = ActiveSheet
            On Error Resume Next
            ws.Name = .Range("B" & iStart).Value
            On Error GoTo 0
            ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
            iStart = iEnd + 1
        End If
    Next i
    End With
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    

    
For Each ws In Sheets
    
    Sheets("Retro").Select
    Range("A1:R1").Copy
    
    If ws.Visible Then ws.Select

    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveSheet.Columns("A:R").AutoFit
    ActiveSheet.Range("A1").Select
    
Next

EDIT: What it seems to be having an issue with is pulling data from Column A rather than B to copy/paste and create new sheets.

 

[NdNoviceHlp]

Trial this...

With ActiveSheet
    lastrow = .Cells(Rows.Count, "B").End(xlUp).Row
    LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    
    iStart = 2
    For i = 2 To lastrow
        If .Range("B" & i).Value <> .Range("B" & i + 1).Value Then
            iEnd = i
            Sheets.Add after:=Sheets(Sheets.Count)
            Set ws = Sheets(Sheets.Count) 'ActiveSheet
            On Error Resume Next
            ws.Name = .Range("B" & iStart).Value
            On Error GoTo 0
            ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
            iStart = iEnd + 1
        End If
    Next i
    End With

HTH. Dave

 

[cmschmitz24]

Hi Dave,

This seems to work better however, there are still more sheets being created than necessary.
For example column B could have the same value in the beginning and also at the end. I think your updated code puts them into multiple sheets rather than on the same sheet because they have the same value.

 

[NdNoviceHlp]

Well I never said that your original code logic did what U wanted it to do because I don't know what that is. Your original request was that the code was pulling data from "A" instead of "B"... you never mentioned that more sheets were being created than necessary or that column B could have the same value in the beginning and also at the end... which I don't understand. I'm guessing that this line of code is wrong and causing more sheets to be made than U need...

If .Range("B" & i).Value <> .Range("B" & i + 1).Value Then

It says that if a value in the active sheet B is not the same as the next row value in B then create a new sheet... I don't get it or why this would be a condition? Maybe clearly state what U want your outcome to be and what the criteria are for B. Dave

 

[cmschmitz24]

Hi Dave,

I apologize for not stating my full intentions on the code however, I have found out how to fix my original code.
Thank you for helping, have a great day.