create new sheet based on cell value and copy data

[Hasson]

hello

I have sheet MAIN contains data from row 4 . the range is (A4:H) and B2= name customer . so what I want if the B2 is Hasson ,then should create new sheet's name is Hasson and copy data from sheet MAIN into sheet Hasson from row2 and if I return to copy data for sheet has already created , then should copy to the bottom and if the name is new based on B2 then should create new sheet and copy the data from row2 and so on

 

[Hasson]

this is what I got

mu.xlsm
	A	B	C	D	E	F	G	H
1	EM	ID	BRAND	MANFACT	REF	BATCH	ORDER	QTY
2	BS-TA-113	QQW-14 L/R EG	CLA14 SS230	DF/100	RF-100	FT-1	AAR1	12
3	BS-TA-117	QQW-181	RRSDF	BRI	RF-101	FT-2	AAR2	234
4	BS-TA-118	QQW-19	CLA19	ITY CV	RF-102	FT-3	AAR3	400
5	BS-TA-119	QQW-20	KV/1**2	CLA20 CV	RF-103	FT-4	AAR4	123
6	BS-TA-107	QQW-8	CLA8	UKI	RF-104	FT-5	AAR5	456
7	BS-TA-108	QQW-9 N	CLA91	BR	RF-105	FT-6	AAR6	600
Hasson

but what I want based on the same thing into sheet main

 

[mumps]

Try:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub
    If Intersect(Target, Range("B2")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet
    Set srcWS = ActiveSheet
    If Not Evaluate("isref('" & Target.Value & "'!A1)") Then
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = Target
        With ActiveSheet
            .Range("A1").Resize(, 8).Value = Array("EM", "ID", "BRAND", "MANFACT", "REF", "BATCH", "ORDER", "QTY")
            srcWS.UsedRange.Offset(4).Copy .Range("A2")
            .Columns.AutoFit
            .Range("A1").Interior.ColorIndex = 23
            .Range("B1").Resize(, 7).Interior.ColorIndex = 33
            .UsedRange.Cells.Borders.LineStyle = xlContinuous
            .UsedRange.Offset(1).Cells.Interior.ColorIndex = 16
        End With
    Else
        With Sheets(Target.Value)
            .UsedRange.Offset(1).ClearContents
            ActiveSheet.UsedRange.Offset(4).Copy .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
        End With
    End If
    Application.ScreenUpdating = True
End Sub

 

[Hasson]

this is what I got

 

[mumps]

Reverse the 23 and 33 in the code. That's pretty close to what you posted in Post #11. If the colours are not exactly what you want, you will have to find the colorindex numbers that correspond to the actual desired colours.

 

[Hasson]

I disabled these lines

.UsedRange.Cells.Borders.LineStyle = xlContinuous
.UsedRange.Offset(1).Cells.Interior.ColorIndex = 16

and change from

            .Range("A1").Interior.ColorIndex = 23

to this

            .Range("A1").Interior.ColorIndex = 33

and I got almost what I want except the headers don't contain the same borders as in the rest of range, also doesn't autofit for
some columns B,C . how fix it?

 

[mumps]

This line of code that you disabled would insert the borders in the whole usedrange:

.UsedRange.Cells.Borders.LineStyle = xlContinuous

This line of code should autofit the columns:

.Columns.AutoFit

Book1
	A	B	C	D	E	F	G	H
1	EM	ID	BRAND	MANFACT	REF	BATCH	ORDER	QTY
2	BS-TA-113	QQW-14 L/R EG	CLA14 SS230	DF/100	RF-100	FT-1	AAR1	12
3	BS-TA-117	QQW-181	RRSDF	BRI	RF-101	FT-2	AAR2	234
4	BS-TA-118	QQW-19	CLA19	ITY CV	RF-102	FT-3	AAR3	400
5	BS-TA-119	QQW-20	KV/1**2	CLA20 CV	RF-103	FT-4	AAR4	123
6	BS-TA-107	QQW-8	CLA8	UKI	RF-104	FT-5	AAR5	456
7	BS-TA-108	QQW-9 N	CLA91	BR	RF-105	FT-6	AAR6	600
Hanson

 

[Hasson]

This line of code that you disabled would insert the borders in the whole usedrange:
VBA Code:
.UsedRange.Cells.Borders.LineStyle = xlContinuous
This line of code should autofit the columns:
VBA Code:
.Columns.AutoFit

this is strange ! but I would from you test it based on attached file and inform me what do you think .
mump.xlsm

 

[mumps]

This version of the macro produces the result below:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub
    If Intersect(Target, Range("B2")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet
    Set srcWS = ActiveSheet
    If Not Evaluate("isref('" & Target.Value & "'!A1)") Then
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = Target
        With ActiveSheet
            .Range("A1").Resize(, 8).Value = Array("ITEM", "ID", "BRAND", "MANFACT", "REF", "BATCH", "ORDER", "QTY")
            srcWS.UsedRange.Offset(4).Copy .Range("A2")
            .UsedRange.Cells.WrapText = False
            .Columns.AutoFit
            .Range("A1").Interior.ColorIndex = 23
            .Range("B1").Resize(, 7).Interior.ColorIndex = 33
           ' .UsedRange.Cells.Borders.LineStyle = xlContinuous
            '.UsedRange.Offset(1).Cells.Interior.ColorIndex = 16
        End With
    Else
        With Sheets(Target.Value)
            .UsedRange.Offset(1).ClearContents
            ActiveSheet.UsedRange.Offset(4).Copy .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
        End With
    End If
    Application.ScreenUpdating = True
End Sub

mump.xlsm
	A	B	C	D	E	F	G	H
1	ITEM	ID	BRAND	MANFACT	REF	BATCH	ORDER	QTY
2	BS-TA-113	QQW-14 L/R EG	CLA14 SS230	DF/100	RF-100	FT-1	AAR1	12
3	BS-TA-117	QQW-181	RRSDF	BRI	RF-101	FT-2	AAR2	234
4	BS-TA-118	QQW-19	CLA19	ITY CV	RF-102	FT-3	AAR3	400
5	BS-TA-119	QQW-20	KV/1**2	CLA20 CV	RF-103	FT-4	AAR4	123
6	BS-TA-107	QQW-8	CLA8	UKI	RF-104	FT-5	AAR5	456
7	BS-TA-108	QQW-9 N	CLA91	BR	RF-105	FT-6	AAR6	600
Hanson

 

[Hasson]

are you sure?
it's big mystery , buddy
I copy the code again based on post#18 and this is what gives me

do you see the borders?

 

[mumps]

Disable or delete these 2 rows of code:

.UsedRange.Cells.Borders.LineStyle = xlContinuous
.UsedRange.Offset(1).Cells.Interior.ColorIndex = 16