Xin code Autofit dòng và cột mà không cần mở file

[Ai_Ma_Biet]

Chào mọi người.

Em có nhiều file cần Autofit dòng và cột, nếu mở từng file và autofit thủ công thì mất thời gian khá nhiều. Không biết code mình có cách nào có thể autofit dòng và cột mà không cần mở file được không. Hoặc cho chỉnh độ rộng dòng, cột mà không cần mở file.

Cám ơn mọi người.

 

[snow25]

Chào mọi người.

Em có nhiều file cần Autofit dòng và cột, nếu mở từng file và autofit thủ công thì mất thời gian khá nhiều. Không biết code mình có cách nào có thể autofit dòng và cột mà không cần mở file được không. Hoặc cho chỉnh độ rộng dòng, cột mà không cần mở file.

Cám ơn mọi người.

Chỉ có code mở file xong đóng lại thôi chứ.Không có code nào không cần mở file đâu.ADO nó cũng phải mở file nhưng mở ở dạng khác.Mà mục đích của bạn để làm gì.

 

[Ai_Ma_Biet]

Chỉ có code mở file xong đóng lại thôi chứ.Không có code nào không cần mở file đâu.ADO nó cũng phải mở file nhưng mở ở dạng khác.Mà mục đích của bạn để làm gì.

Mình tìm code xuất từ 1sheet ra thành nhiều file trên GPE, xuất ra rồi nhưng dữ liệu các cột không tự autofilt nên mình nhờ code autofit, không biết Nhờ Anh chỉnh giúp em code này xuất ra và tự autofit hoặc lấy theo độ rộng của file gốc giúp em.

Sub Export()
  Dim dic As Object, rngSrc As Range, wkbNew As Workbook
  Dim aIDs, n As Long
  Dim sFolder As String, FileName As String, SheetName As String
  sFolder = ThisWorkbook.Path & "\Bao cao tuan 25_"
  Set rngSrc = ThisWorkbook.Worksheets("Sum").Range("A1:U1200")
  aIDs = rngSrc.Offset(1).Columns("D:E").Value 
  Set dic = CreateObject("Scripting.Dictionary")
  Application.ScreenUpdating = False
  rngSrc.Range("IV1").Value = rngSrc.Range("E1").Value     
  For n = 1 To UBound(aIDs, 1)
    If Len(aIDs(n, 1)) * Len(aIDs(n, 2)) Then
      SheetName = aIDs(n, 2):  FileName = aIDs(n, 2) 
      If Not dic.Exists(SheetName) Then
        dic.Add SheetName, Empty
        Set wkbNew = Workbooks.Add(1)
        wkbNew.Sheets(1).Name = SheetName
        rngSrc.Range("IV2").Value = "'=" & SheetName
        rngSrc.AdvancedFilter 2, rngSrc.Range("IV1:IV2"), wkbNew.Sheets(1).Range("A1")
        wkbNew.SaveAs sFolder & FileName, xlOpenXMLWorkbook       
        wkbNew.Close False
      End If
    End If
  Next
  Application.ScreenUpdating = True
  rngSrc.Range("IV1:IV2").ClearContents
  If dic.Count Then MsgBox "Ða luu " & dic.Count & " workbooks", , "THÔNG BÁO"
End Sub

 

[snow25]

Mình tìm code xuất từ 1sheet ra thành nhiều file trên GPE, xuất ra rồi nhưng dữ liệu các cột không tự autofilt nên mình nhờ code autofit, không biết Nhờ Anh chỉnh giúp em code này xuất ra và tự autofit hoặc lấy theo độ rộng của file gốc giúp em.

Sub Export()
  Dim dic As Object, rngSrc As Range, wkbNew As Workbook
  Dim aIDs, n As Long
  Dim sFolder As String, FileName As String, SheetName As String
  sFolder = ThisWorkbook.Path & "\Bao cao tuan 25_"
  Set rngSrc = ThisWorkbook.Worksheets("Sum").Range("A1:U1200")
  aIDs = rngSrc.Offset(1).Columns("D:E").Value
  Set dic = CreateObject("Scripting.Dictionary")
  Application.ScreenUpdating = False
  rngSrc.Range("IV1").Value = rngSrc.Range("E1").Value    
  For n = 1 To UBound(aIDs, 1)
    If Len(aIDs(n, 1)) * Len(aIDs(n, 2)) Then
      SheetName = aIDs(n, 2):  FileName = aIDs(n, 2)
      If Not dic.Exists(SheetName) Then
        dic.Add SheetName, Empty
        Set wkbNew = Workbooks.Add(1)
        wkbNew.Sheets(1).Name = SheetName
        rngSrc.Range("IV2").Value = "'=" & SheetName
        rngSrc.AdvancedFilter 2, rngSrc.Range("IV1:IV2"), wkbNew.Sheets(1).Range("A1")
        wkbNew.SaveAs sFolder & FileName, xlOpenXMLWorkbook      
        wkbNew.Close False
      End If
    End If
  Next
  Application.ScreenUpdating = True
  rngSrc.Range("IV1:IV2").ClearContents
  If dic.Count Then MsgBox "Ða luu " & dic.Count & " workbooks", , "THÔNG BÁO"
End Sub

Bạn gửi Cái File lên.Cho 1 cái File cần cần tách và kết quả của nó như thế nào.

 

[Ai_Ma_Biet]

Bạn gửi Cái File lên.Cho 1 cái File cần cần tách và kết quả của nó như thế nào.

Nó ra mỗi cột có độ rộng là 8.38

 

[♫ђöล♥ßล†♥†µ♫]

Nó ra mỗi cột có độ rộng là 8.38

Sao mình chạy nó vẫn giống file gốc nhỉ

 

[snow25]

Nó ra mỗi cột có độ rộng là 8.38

Bạn thử code này xem.Thêm 1 chút.

Sub Export()
  Dim dic As Object, rngSrc As Range, wkbNew As Workbook, tong As Worksheet, i As Integer
  Dim aIDs, n As Long
  Dim sFolder As String, FileName As String, SheetName As String
  sFolder = ThisWorkbook.Path & "\Export_"
  Set rngSrc = ThisWorkbook.Worksheets("Sheet8").Range("A1:AL9000")
  Set tong = ThisWorkbook.Worksheets("sheet8")
  aIDs = rngSrc.Offset(1).Columns("A:B").Value
  Set dic = CreateObject("Scripting.Dictionary")
  Application.ScreenUpdating = False
  rngSrc.Range("IV1").Value = rngSrc.Range("A1").Value
  For n = 1 To UBound(aIDs, 1)
    If Len(aIDs(n, 1)) * Len(aIDs(n, 2)) Then
      SheetName = aIDs(n, 1):  FileName = aIDs(n, 1)
      If Not dic.Exists(SheetName) Then
        dic.Add SheetName, Empty
        Set wkbNew = Workbooks.Add(1)
        wkbNew.Sheets(1).Name = SheetName
        rngSrc.Range("IV2").Value = "'=" & SheetName
        rngSrc.AdvancedFilter 2, rngSrc.Range("IV1:IV2"), wkbNew.Sheets(1).Range("A1")
        For i = 1 To 4
            wkbNew.Sheets(1).Columns(i).ColumnWidth = tong.Columns(i).ColumnWidth
        Next i
        wkbNew.SaveAs sFolder & FileName, xlOpenXMLWorkbook
        wkbNew.Close False
      End If
    End If
  Next
  Application.ScreenUpdating = True
  rngSrc.Range("IV1:IV2").ClearContents
  If dic.Count Then MsgBox "Ða luu " & dic.Count & " workbooks", , "THÔNG BÁO"
End Sub

 

[ThangCuAnh]

Ai mà biết nhét thêm 2 dòng code này vào đúng chỗ là nó chạy tốt thôi

.............
        wkbNew.Sheets(1).UsedRange.Columns.AutoFit
        wkbNew.Sheets(1).UsedRange.Rows.AutoFit
.............