delete one of values colums by split data into two sheets

[Alaa mg]

HI

I have about 6700 rows .I want split data sheet by keep one values column for each item for each sheet separately by create the sheets based on headers MONTH1,2 and every time will change and update data in first sheet ,then should update data in divided sheets by clearing data before bring data again with keep the same formatting and borders in divided sheets .

DATA.xlsm
	A	B	C	D
1	ITEM	ID	MONTH1	MONTH2
2	1	MT ASGL-VEN SD-1	12	10
3	2	C-ZER MN/100 TR12	130	0
4	3	BB 2000MN TT GH	90	0
5	4	TRM 2000MN TT GH		16
6	5	BD 234 NH GG	80	90
7	6	BR 111/33M ER HJ	70	90
8	8	VB 145** SS TF HJK	0	45
9	9	DEWR 1222** SS TF HJK	34	30
sheet1

result

DATA.xlsm
	A	B	C
1	ITEM	ID	MONTH1
2	1	MT ASGL-VEN SD-1	12
3	2	C-ZER MN/100 TR12	130
4	3	BB 2000MN TT GH	90
5	4	TRM 2000MN TT GH
6	5	BD 234 NH GG	80
7	6	BR 111/33M ER HJ	70
8	8	VB 145** SS TF HJK	0
9	9	DEWR 1222** SS TF HJK	34
MONTH1

DATA.xlsm
	A	B	C
1	ITEM	ID	MONTH2
2	1	MT ASGL-VEN SD-1	10
3	2	C-ZER MN/100 TR12	0
4	3	BB 2000MN TT GH	0
5	4	TRM 2000MN TT GH	16
6	5	BD 234 NH GG	90
7	6	BR 111/33M ER HJ	90
8	8	VB 145** SS TF HJK	45
9	9	DEWR 1222** SS TF HJK	30
MONTH2

 

[Alaa mg]

this is strange !! . I thought can show error subscript out of range . this beacuse of not matched sheet name

Ok this works . just curiosity can I ignore any item contains empty or zero value when split it . I mean deleting the whole items contains zero or empty value for sheets MONTH1,2. I know this doesn't mentioned in OP as I said just curiosity if you can't I will satisfy your answering and close the thread.

thanks again

 

[bebo021999]

No problem.
try this. (The added part is 4 lines from bottom, right before the last End IF)

Option Explicit
Sub test()
Dim lc&, lr&, rng, cell As Range, item, ws As Worksheet
Application.ScreenUpdating = False
Worksheets("Sheet1").Activate
    lc = Cells(1, Columns.Count).End(xlToLeft).Column
    rng = Range("C1", Cells(1, lc)).Value
    For Each item In rng
        For Each ws In Sheets
            If ws.Name Like item Then ws.Delete
        Next
        Worksheets("Sheet1").Copy after:=Worksheets(Sheets.Count)
        ActiveSheet.Name = item
    Next
    For Each ws In Sheets
        If ws.Name <> "Sheet1" Then
            For Each cell In ws.Range("C1", ws.Cells(1, lc))
                If Not cell.Value Like ws.Name Then cell.Value = "#N/A"
            Next
            ws.Range("C1", ws.Cells(1, lc)).SpecialCells(xlCellTypeConstants, xlErrors).EntireColumn.Delete
            lr = ws.Cells(Rows.Count, "B").End(xlUp).Row
            ws.Range("D2:D" & lr).Formula = "=1/(1/C2)"
            ws.Range("D2:D" & lr).SpecialCells(xlCellTypeFormulas, xlErrors).EntireRow.Delete
            ws.Columns(4).Delete
        End If
    Next
    Application.ScreenUpdating = True
End Sub

 

[Alaa mg]

wow ! you're legend !

can I ask you ? you don't use dictionary & array and the code is very fast somtimes somebody using dictionary and array to make fast but I don't think will be fast like this . may you tell me what's the secret if you don't mind , which code line control the speed?

 

[bebo021999]

OK.

Alternative way
1) Using array (or dictionary), to copy body range of sheet1 (base on condition of MONTH), then paste into each sheet MONTH
2) For each sheet MONTH, loop for each cell in column C then delete rows those are blank or = 0

My approach:
1) This just dupplicate Sheet1, not copy range base on condition. Then delete columns
2) Using column D as helper, paste a formula (in bulk, not loop) (this line: ws.Range("D2:D" & lr).Formula = "=1/(1/C2)"). Now, In any row of column C = 0 or empty, column D = "Div/0"
Using specialcells to delete all rows with error (in bulk, not loop)
This line:
ws.Range("D2:D" & lr).SpecialCells(xlCellTypeFormulas, xlErrors).EntireRow.Delete

To get better code speed, try to avoid using loop on worksheet range.

 

[Alaa mg]

much appreciated for two solution and explanation
thank you so much