Nhờ sửa code để file mới tạo có độ rộng cột như file gốc

[Hello World Cup]

Xin chào mọi người,

Mình tìm được file trên mạng, rất mong mọi người giúp mình chỉnh sửa code để tạo ra các file con có độ rộng cột như file gốc ạ. Nếu được, file gốc có định dạng như thế nào, hiển thị như thế nào thì file con cũng như vậy thì càng tốt ạ.

Option Explicit

Sub ExportFiles()
Dim cotcanloc As Integer

Dim arr(), Dic As Object, Rng As Range, Wb As Workbook
Dim i&, k&, endR&, dKey$, fPath$, fName$, tmr#
tmr = Timer()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


cotcanloc = Sheet2.Range("B2").Value

'fPath = "D:" & "\"

fPath = Sheet2.Range("B3").Value

If Sheet1.AutoFilterMode Then Sheet1.AutoFilterMode = False
endR = Sheet1.Range("B" & Rows.Count).End(xlUp).Row
Set Rng = Sheet1.Range("A1:ZZ" & endR)
Rng.AutoFilter
Set Dic = CreateObject("Scripting.Dictionary")
For i = 2 To Rng.Rows.Count
    dKey = Rng(i, cotcanloc)
    If Not Dic.Exists(dKey) Then
        k = k + 1
        Dic.Add dKey, k
        ReDim Preserve arr(1 To k)
        arr(k) = dKey
    End If
Next
For i = 1 To k
    Rng.AutoFilter cotcanloc, arr(i)
    Union(Sheet1.Range("A1:ZZ1"), Rng).SpecialCells(xlCellTypeVisible).Copy
    Set Wb = Workbooks.Add
    Wb.Sheets("Sheet1").Range("A1").PasteSpecial xlPasteAll
    'Workbooks.Sheets("Sheet1").EntireColumn.AutoFit
    fName = arr(i) & Format(Format(Now(), " yymmdd hhmmss")) & ".xlsx"
    Wb.Close True, fPath & fName
    Set Wb = Nothing
Next
Set Dic = Nothing
MsgBox "Done!" & vbNewLine & Timer() - tmr & " seconds"
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Sheet1.AutoFilterMode = False
Rng.AutoFilter
End Sub

Mình xin gửi kèm file, cám ơn mọi người rất nhiều ạ.

 

[Hoàng Tuấn 868]

Xin chào mọi người,

Mình tìm được file trên mạng, rất mong mọi người giúp mình chỉnh sửa code để tạo ra các file con có độ rộng cột như file gốc ạ. Nếu được, file gốc có định dạng như thế nào, hiển thị như thế nào thì file con cũng như vậy thì càng tốt ạ.

Option Explicit

Sub ExportFiles()
Dim cotcanloc As Integer

Dim arr(), Dic As Object, Rng As Range, Wb As Workbook
Dim i&, k&, endR&, dKey$, fPath$, fName$, tmr#
tmr = Timer()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


cotcanloc = Sheet2.Range("B2").Value

'fPath = "D:" & "\"

fPath = Sheet2.Range("B3").Value

If Sheet1.AutoFilterMode Then Sheet1.AutoFilterMode = False
endR = Sheet1.Range("B" & Rows.Count).End(xlUp).Row
Set Rng = Sheet1.Range("A1:ZZ" & endR)
Rng.AutoFilter
Set Dic = CreateObject("Scripting.Dictionary")
For i = 2 To Rng.Rows.Count
    dKey = Rng(i, cotcanloc)
    If Not Dic.Exists(dKey) Then
        k = k + 1
        Dic.Add dKey, k
        ReDim Preserve arr(1 To k)
        arr(k) = dKey
    End If
Next
For i = 1 To k
    Rng.AutoFilter cotcanloc, arr(i)
    Union(Sheet1.Range("A1:ZZ1"), Rng).SpecialCells(xlCellTypeVisible).Copy
    Set Wb = Workbooks.Add
    Wb.Sheets("Sheet1").Range("A1").PasteSpecial xlPasteAll
    'Workbooks.Sheets("Sheet1").EntireColumn.AutoFit
    fName = arr(i) & Format(Format(Now(), " yymmdd hhmmss")) & ".xlsx"
    Wb.Close True, fPath & fName
    Set Wb = Nothing
Next
Set Dic = Nothing
MsgBox "Done!" & vbNewLine & Timer() - tmr & " seconds"
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Sheet1.AutoFilterMode = False
Rng.AutoFilter
End Sub

Mình xin gửi kèm file, cám ơn mọi người rất nhiều ạ.

Tìm được code ở mạng nào thì nhờ chính chủ mạng đó sửa có hơn không bạn.

 

[Phuocam]

Wb.Sheets("Sheet1").Range("A1").PasteSpecial xlPasteAll

Thử thêm dòng này vào :

Wb.Sheets("Sheet1").Range("A1").PasteSpecial xlPasteAll
Wb.Sheets("Sheet1").Range("A1").PasteSpecial xlPasteColumnWidths

 

[Hello World Cup]

Thử thêm dòng này vào :

Wb.Sheets("Sheet1").Range("A1").PasteSpecial xlPasteAll
Wb.Sheets("Sheet1").Range("A1").PasteSpecial xlPasteColumnWidths

Cám ơn bạn. Mình chuyển dòng code 2 lên trên thì file chạy đúng mong đợi. Nếu mình giữ nguyên thì có nhiều file không có dữ liệu, chỉ có định dạng.