VBA split sheets based on multiple condition and preserving format and column width

Agniz · May 9th 2019

I am brand new to VBA and need some help with the below code. It works well and splits the data based on two filters, but does not preserve column width.
Could please someone assist and guide me?

Thank you.

Code

Sub ertert()
Dim x, i&, s$, d As Object
Set d = CreateObject("Scripting.Dictionary"): d.CompareMode = 1
Application.ScreenUpdating = 0
With Sheets("Raw data")
    .AutoFilterMode = False
    With .Range("A1:K" & .Cells(Rows.Count, 1).End(xlUp).Row)
        x = .Value
        For i = 2 To UBound(x)
            s = x(i, 4) & " " & x(i, 5)
            If Not d.Exists(s) Then
                d.Item(s) = 1
                If Not Evaluate("ISREF('" & s & "'!A1)") Then
                    Sheets.Add(after:=Sheets(Sheets.Count)).Name = s
                Else
                    Sheets(s).UsedRange.ClearContents
                End If
                .AutoFilter Field:=4, Criteria1:=x(i, 4)
                .AutoFilter Field:=5, Criteria1:=x(i, 5)
                .Copy Sheets(s).Cells(1)
                                                                
            End If
        Next i
        .AutoFilter
                
    End With
End With
Set d = Nothing
With Application
    .CutCopyMode = False: .ScreenUpdating = True
End With
End Sub

Display More

**StephenR** · May 9th 2019

Might be enough to add this after your current Copy line:

Code

.Copy
Sheets(s).cells(1).pastespecial xlPasteColumnWidths

Agniz · May 10th 2019

Thank you StephenR. Unfortunately, I am getting this error:

[ATTACH=JSON]{"data-align":"none","data-size":"full","title":"Capture.JPG","data-attachmentid":1218366}[/ATTACH]

**StephenR** · May 10th 2019

Keep your existing Copy line and add my code afterwards, keeping it on two lines as I posted it.

Agniz · May 10th 2019

Used the code like suggested, it splits keeping the format and columns width, but it is not copying any data. Any ideas what I am doing wrong? Thank you.

Code

Sub ertert()
Dim x, i&, s$, d As Object
Set d = CreateObject("Scripting.Dictionary"): d.CompareMode = 1
Application.ScreenUpdating = 0
With Sheets("Raw data")
    .AutoFilterMode = False
    With .Range("A1:K" & .Cells(Rows.Count, 1).End(xlUp).Row)
        x = .Value
        For i = 2 To UBound(x)
            s = x(i, 4) & " " & x(i, 5)
            If Not d.Exists(s) Then
                d.Item(s) = 1
                If Not Evaluate("ISREF('" & s & "'!A1)") Then
                    Sheets.Add(after:=Sheets(Sheets.Count)).Name = s
                Else
                    Sheets(s).UsedRange.ClearContents
                End If
                .AutoFilter Field:=4, Criteria1:=x(i, 4)
                .AutoFilter Field:=5, Criteria1:=x(i, 5)
                .Copy Sheets(s).Cells(1)
                .Copy
                Sheets(s).Cells(1).PasteSpecial xlPasteColumnWidths
            End If
        Next i
        .AutoFilter
                
    End With
End With
Set d = Nothing
With Application
    .CutCopyMode = False: .ScreenUpdating = True
End With
End Sub

Display More

Agniz · May 10th 2019

I've worked it out, thank very much for your help!

VBA split sheets based on multiple condition and preserving format and column width

Participate now!

Share