Split Data from One Sheet to Different Sheets using VBA

[Haree]

Hello,
I have various sheets in excel approximately 30 to 35 sheets, basically one for each SKU i have a main sheet in which i will enter that days sales or purchase for all the SKU'S they should get posted in their respective sheets. I am attaching a sample sheet, Kindly guide me on how to do the same.
Thanks in advance

New Stock Try.xlsx

drive.google.com

 

[My Aswer Is This]

No Sir it Worked perfectly alright that's y i said so. Now all of a sudden this popped up that's why asked

Ok. But what has changed. Are you sure all sheet names are the same?
I suspect you have a value in column A that is not a sheet name.

 

[Haree]

so sorry wasn't able to reply due to the ongoing pandemic. i had merged a cell. apparently that has been the cause of the error. i am so sorry. now its working fine.
Hope you are doing good, and you are safe.

 

[My Aswer Is This]

so sorry wasn't able to reply due to the ongoing pandemic. i had merged a cell. apparently that has been the cause of the error. i am so sorry. now its working fine.
Hope you are doing good, and you are safe.

Glad to hear you have things working. Many on this forum advise not using Merged cells for a variety of reasons especially when using Vba.
Thanks for thinking of me and yes I'm doing well here and glad to know your staying safe also.

 

[Haree]

Hello @My Aswer Is This,

Sorry to trouble you again have a small doubt. I had made little adjustments to the codes which you had given to suit my work It is still working perfectly fine. I just have a small problem in the number of rows copying. Initially you had set the value as 40. I had changed it to 5 and have been working in it ever since. but now at the current onset i require only 4 rows when I change the value to 4 its looping to all the cells in that particular row. Attaching a screenshot for your reference.

16-05-2021​

Sales

1​

1​

16-05-2021​

Sales

1​

1​

#######​

Sales

1​

1​

#######​

Sales

1​

1​

But when I Changed the rows to 6 or 3 its working perfectly fine . The problem is only with 4 can you please guide me as in where I have gone wrong or what's the reason. Thank you so much for your valuable time. I am attaching the current code

Sub Copy_Rows()
Application.ScreenUpdating = False
Dim R As Range, Cell As Range
Set R = Range("H2:H200")
For Each Cell In R
If Cell.Value = "Error" Then
MsgBox "Kindly Check Errors and try again"
Exit Sub
End If
Next Cell
Range("B2:B200").Select
    Selection.Replace What:=".", Replacement:="-", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
Dim Drange As Range
Dim psheet As Worksheet
Set Drange = Range("A2:E200")
For Each psheet In Worksheets
psheet.Unprotect Password:="STOCK"
Next psheet
Sheets("Data Sheet").Activate
Dim i As Long
Dim Lastrow As Long
Lastrow = Sheets("Data Sheet").Cells(Rows.Count, "A").End(xlUp).Row
Dim Lastrowa As Long
For i = 2 To Lastrow
Lastrowa = Sheets(Cells(i, 1).Value).Cells(Rows.Count, "A").End(xlUp).Row + 1
Cells(i, 2).Resize(, 4).Copy Sheets(Cells(i, 1).Value).Rows(Lastrowa)
Next
Drange.ClearContents
For Each psheet In Worksheets
If psheet.Name = "Data Sheet" Then
psheet.Unprotect Password:="STOCK"
Else
psheet.Protect Password:="STOCK", AllowFormattingCells:=True, DrawingObjects:=False, Scenarios:= _
        True
End If
Next psheet
MsgBox "Data Updated Successfully"
Application.ScreenUpdating = True
End Sub

 

[My Aswer Is This]

Hello @My Aswer Is This,

Sorry to trouble you again have a small doubt. I had made little adjustments to the codes which you had given to suit my work It is still working perfectly fine. I just have a small problem in the number of rows copying. Initially you had set the value as 40. I had changed it to 5 and have been working in it ever since. but now at the current onset i require only 4 rows when I change the value to 4 its looping to all the cells in that particular row. Attaching a screenshot for your reference.

16-05-2021​

Sales

1​

1​

16-05-2021​

Sales

1​

1​

#######​

Sales

1​

1​

#######​

Sales

1​

1​

But when I Changed the rows to 6 or 3 its working perfectly fine . The problem is only with 4 can you please guide me as in where I have gone wrong or what's the reason. Thank you so much for your valuable time. I am attaching the current code

Sub Copy_Rows()
Application.ScreenUpdating = False
Dim R As Range, Cell As Range
Set R = Range("H2:H200")
For Each Cell In R
If Cell.Value = "Error" Then
MsgBox "Kindly Check Errors and try again"
Exit Sub
End If
Next Cell
Range("B2:B200").Select
    Selection.Replace What:=".", Replacement:="-", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
Dim Drange As Range
Dim psheet As Worksheet
Set Drange = Range("A2:E200")
For Each psheet In Worksheets
psheet.Unprotect Password:="STOCK"
Next psheet
Sheets("Data Sheet").Activate
Dim i As Long
Dim Lastrow As Long
Lastrow = Sheets("Data Sheet").Cells(Rows.Count, "A").End(xlUp).Row
Dim Lastrowa As Long
For i = 2 To Lastrow
Lastrowa = Sheets(Cells(i, 1).Value).Cells(Rows.Count, "A").End(xlUp).Row + 1
Cells(i, 2).Resize(, 4).Copy Sheets(Cells(i, 1).Value).Rows(Lastrowa)
Next
Drange.ClearContents
For Each psheet In Worksheets
If psheet.Name = "Data Sheet" Then
psheet.Unprotect Password:="STOCK"
Else
psheet.Protect Password:="STOCK", AllowFormattingCells:=True, DrawingObjects:=False, Scenarios:= _
        True
End If
Next psheet
MsgBox "Data Updated Successfully"
Application.ScreenUpdating = True
End Sub

This code your showing here is not the code I provided. I suggest you start a new posting explaining in detail what your needs are