Cut/Paste Data by matching cell to sheet name

[MongeredRue]

I run a report on a weekly basis, via separate software, and I have to distribute the data from the report into the corresponding sheets. I'm trying to do this in VBA, because i'm sick of doing it by hand, but I'm getting stuck on the most critical part: cutting the data and pasting it to the appropriate sheet. Any help would be appreciated!!

Worksheets("Working Sheet").Activate

Dim ws As Worksheet
Dim LR As Long, LR2 As Long, x As Long, i As Long

Application.ScreenUpdating = False

With Sheets("Working Sheet")
    LR = .Range("B" & .Rows.Count).End(xlUp).Row
    x = .Cells(1, Columns.Count).End(xlToLeft).Column
End With

For Each ws In ActiveWorkbook.Sheets
    If ws.Name <> "Working Sheet" Then ws.Cells.ClearContents
Next ws


    For Each ws In ActiveWorkbook.Sheets
        With ws
            LR2 = .Range("B" & .Rows.Count).End(xlUp).Row + 1
            For i = 1 To LR
                If ws.Name = Sheets("Working Sheet").Range("B" & 1).Value Then
                .Rows(i).Cut Destination:=Sheets(ws.Name).Range("A" & Rows.Count).End(xlUp).Offset(1)
                Exit For
            End If
            Next i
        End With
    Next ws


Application.ScreenUpdating = True

 

[Fluff]

Hi & welcome to MrExcel.
As you haven't told us what is not working, this is a guess, but try changing the 1 to an i

If ws.Name = Sheets("Working Sheet").Range("B" & [COLOR=#ff0000]1[/COLOR]).Value Then

 

[MongeredRue]

Sorry, I should have been more specific.

This is the section that doesn't work.

 For Each ws In ActiveWorkbook.Sheets
        With ws
            LR2 = .Range("B" & .Rows.Count).End(xlUp).Row + 1
            For i = 1 To LR
                If ws.Name = Sheets("Working Sheet").Range("B" & 1).Value Then
                .Rows(i).Cut Destination:=Sheets(ws.Name).Range("A" & Rows.Count).End(xlUp).Offset(1)
                Exit For
            End If
            Next i

The sheets clear like they're supposed to and the code runs all the way through without errors but the data doesn't get pulled from the main sheet ("Working Sheet") to any of the other sheets.

The above is a modification of the code below. The code below almost worked but would only pull the header line over to the new sheet instead of every instance of the cell
matching the sheet name. If you could help get either one to work, that'd be great. Is there any more info I can provide to assist in troubleshooting?

(I tried the 1 to i correction; no change)

Sub macro1()

Dim ws As Worksheet
Dim LR As Long, LR2 As Long, x As Long

Application.ScreenUpdating = False

With Sheets("Sheet1")
    LR = .Range("A" & .Rows.Count).End(xlUp).Row
    x = .Cells(1, Columns.Count).End(xlToLeft).Column
End With

For Each ws In ActiveWorkbook.Sheets
    If ws.name <> "Sheet1" Then ws.Cells.ClearContents
Next ws

For i = 1 To LR
    For Each ws In ActiveWorkbook.Sheets
        With ws
            If .name = Sheets("Sheet1").Range("C" & i).Value Then
                LR2 = .Range("A" & .Rows.Count).End(xlUp).Row + 1
                .Range("A" & LR2).Resize(1, x).Value = Sheets("Sheet1").Range("A1").Resize(1, x).Value
                Exit For
            End If
        End With
    Next ws
Next i

Application.ScreenUpdating = True

End Sub

 

[Fluff]

Try removing this line

 Exit For

 

[MongeredRue]

Still nothing.....is there a way for me to post a workbook? I'll be easier to demonstrate than explain.

 

[Fluff]

You cannot post a workbook to the site,but you can upload to a share site such as dropbox, onedrive, googledrive, mark for sharing & then post a link to the thread.