HỖ TRỢ CHUYỂN ĐỔI CODE SANG MẢNG

[Hoàng Đình Huy]

Hi các anh/chị trong giaiphapexcel ạ.

Hiện tại em đang có code này, nhờ các anh/chị hỗ trợ giúp em chuyển code này sang dạng mảng để khi sử dụng được nhanh hơn được không ạ. E xin chân thành cảm ơn.

Sub tachsheet()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
On Error GoTo ib
Dim sh As Worksheet 'BIEN CHAY
Dim ws As Worksheet ' SHEET MOI
Dim wbm As Workbook ' WB MOI
Dim wb As Workbook ' WB GOC
Dim Tmr As Double
Tmr = Timer()
Set wb = ThisWorkbook

For Each sh In wb.Worksheets
Set ws = Sheets.Add(After:=Sheets(Worksheets.Count))
sh.Range("a6:i" & sh.[a1048576].End(xlUp).Row).Copy
ws.Range("a1").PasteSpecial xlPasteValues
ws.Copy
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & sh.Name
ActiveWorkbook.Close
ws.Delete
Next
ib:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Thoi gian chay file: " & Round((Timer() - Tmr) / 60, 1) & " phut"
End Sub

 

[Cá ngừ F1]

Ý của bạn là copy 1/nhiều sheet thành 1 File mới?

 

[ptm0412]

For Each sh In wb.Worksheets
Set ws = Sheets.Add(After:=Sheets(Worksheets.Count))
sh.Range("a6:i" & sh.[a1048576].End(xlUp).Row).Copy
ws.Range("a1").PasteSpecial xlPasteValues

Sửa thành:

For Each sh In wb.Worksheets
Set ws = Sheets.Add(After:=Sheets(Worksheets.Count))
LastRw = sh.[a100000].End(xlUp).Row
ws.Range("a1:i" & LastRw).Value = sh.Range("a6:i" & LastRw).Value

Nhưng chẳng nhanh hơn bao nhiêu, vì không xử lý gì

 

[Hoàng Đình Huy]

Ý của bạn là copy 1/nhiều sheet thành 1 File mới?

Dạ đúng rồi anh ạ.

Bài đã được tự động gộp: 10/8/21

Sửa thành:

For Each sh In wb.Worksheets
Set ws = Sheets.Add(After:=Sheets(Worksheets.Count))
LastRw = sh.[a100000].End(xlUp).Row
ws.Range("a1:i" & LastRw).Value = sh.Range("a6:i" & LastRw).Value

Nhưng chẳng nhanh hơn bao nhiêu, vì không xử lý gì

Do em thấy mọi người nói dùng array sẽ nhanh hơn nữa, em ko biết cách code array nó ntn hết ạ

 

[Cá ngừ F1]

Nếu thực sự bạn muốn copy sheet thành file thì nên dùng hàm SaveSheet của Huyền thoại GPE @NDU (Tôi không nhớ là ở thớt nào).
Cứ copy vô, chỉnh sửa ở Sub Main là chạy phè phè thôi

Option Explicit
Function SaveSheet(ByVal Sheets2Save As Object, ByVal FileName2Save As String, _
                   ByVal FileFormat As XlFileFormat, ByVal OverWrite As Boolean) As String
  Dim bChk As Boolean
  Dim Folder2Save As String, sComm As String, Ext As String, ErrMsg As String
  Dim fso As Object, oWsh As Object, wkb As Workbook
  On Error GoTo ExitFunc
  Set fso = CreateObject("Scripting.FileSystemObject")
  bChk = fso.FileExists(FileName2Save)
  If (bChk = False) Or OverWrite Then
    Folder2Save = Mid(FileName2Save, 1, InStrRev(FileName2Save, "\") - 1)
    If fso.FolderExists(Folder2Save) = False Then
      Set oWsh = CreateObject("Wscript.Shell")
      sComm = "MkDir " & """" & Folder2Save & """"
      oWsh.Run "cmd /u /c " & sComm, 0, True
    End If
    If fso.FolderExists(Folder2Save) Then
      Ext = fso.GetExtensionName(FileName2Save)
      If Len(Ext) Then FileName2Save = Left(FileName2Save, Len(FileName2Save) - Len(Ext) - 1)
      If (TypeName(Sheets2Save) = "Sheets") Or (TypeName(Sheets2Save) = "Worksheet") Then
        Application.DisplayAlerts = False
        Sheets2Save.Copy
        Set wkb = ActiveWorkbook
        With wkb
          .SaveAs FileName2Save, FileFormat
          SaveSheet = .FullName
          .Close (True)
        End With
        Application.DisplayAlerts = True
      End If
    End If
  End If
ExitFunc:
  ErrMsg = Err.Description
  If Err.Number = 1004 Then
    If Not wkb Is Nothing Then
      If UCase(wkb.Name) <> UCase(Sheets2Save.Parent.Name) Then wkb.Close (False)
    End If
    MsgBox ErrMsg
  End If
  Set fso = Nothing: Set oWsh = Nothing
End Function
Sub Main()
' XlFileFormat = xlExcel8                      <===> File Extension = "xls"
' XlFileFormat = xlOpenXMLWorkbook             <===> File Extension = "xlsx"
' XlFileFormat = xlExcel12                     <===> File Extension = "xlsb"
' XlFileFormat = xlOpenXMLWorkbookMacroEnabled <===> File Extension = "xlsm"
  Dim wks As Object, FileFormat As XlFileFormat
  Dim FileName As String, szSaved As String
  Application.ScreenUpdating = False
  Set wks = ThisWorkbook.Sheets(Array("Sheet1", "Sheet2")) '>> wks bao gom nhieu sheet
  'Set wks = ThisWorkbook.Worksheets("Sheet1")             '>> wks là 1 sheet duy nhat
  FileName = "D:\ABC\Test.xls"
  FileFormat = xlExcel8
  szSaved = SaveSheet(wks, FileName, FileFormat, True)
  If Len(szSaved) Then MsgBox "File """ & szSaved & """ have been successfully saved!"
  Application.ScreenUpdating = True
End Sub

Cho phép chọn loại File xuất, chọn sheet cần xuất...

 

[Maika8008]

Dạ đúng rồi anh ạ.

Bài đã được tự động gộp: 10/8/21

Do em thấy mọi người nói dùng array sẽ nhanh hơn nữa, em ko biết cách code array nó ntn hết ạ

Nếu dùng mảng thì chỉ có động tác chép dữ liệu nguồn vào mảng rồi chép mảng đó ra sheet đích. Có nhanh hơn được bao nhiêu không, chưa rõ lắm.

 

[ptm0412]

Dạ đúng rồi anh ạ.

Bài đã được tự động gộp: 10/8/21

Do em thấy mọi người nói dùng array sẽ nhanh hơn nữa, em ko biết cách code array nó ntn hết ạ

ntn là gì vậy? Mất công đoán quá. Code tôi viết trên không dùng mảng, mà nếu dùng mảng chắc cũng chỉ vậy thôi, không nhanh hơn bao nhiêu. Mảng nhanh trong trường hợp tương tác với cells, range trên sheet nhiều lần hoặc rất nhiều lần. Trong bài copy nguyên vùng dữ liệu thì chỉ tương tác lên sheet 1 lần lúc copy và 1 lần lúc paste.

 

[Hoàng Đình Huy]

ntn là gì vậy? Mất công đoán quá. Code tôi viết trên không dùng mảng, mà nếu dùng mảng chắc cũng chỉ vậy thôi, không nhanh hơn bao nhiêu. Mảng nhanh trong trường hợp tương tác với cells, range trên sheet nhiều lần hoặc rất nhiều lần. Trong bài copy nguyên vùng dữ liệu thì chỉ tương tác lên sheet 1 lần lúc copy và 1 lần lúc paste.

Dạ em thử tốc độ nó cải thiện nhanh lắm ạ, em cảm ơn anh ạ.

 

[befaint]

Copy sẽ lấy mọi thứ của nguồn, tốn nhiều dung lượng bộ nhớ, tất nhiên tốn nhiều thời gian lấy và chép lại.
Lấy dữ liệu vào mảng chỉ lấy phần giá trị, cần ít bộ nhớ và cần ít thời gian hơn cách trên.
Thao tác ít thì cơ bản không chênh lệch nhiều, và ngược lại.

 

[qtm1987]

Sửa thành:

For Each sh In wb.Worksheets
Set ws = Sheets.Add(After:=Sheets(Worksheets.Count))
LastRw = sh.[a100000].End(xlUp).Row
ws.Range("a1:i" & LastRw).Value = sh.Range("a6:i" & LastRw).Value

Nhưng chẳng nhanh hơn bao nhiêu, vì không xử lý gì

Bạn ơi, mình giả lập 1 vùng dữ liệu toàn là số 1 từ vùng A1: I1048570 và sửa LastRw=sh.[A1048576].end(xlup).row.
So sánh tốc độ thì code mới khoản 20s, sao trong trường hợp này tốc độ lại chậm hơn khi dùng code cũ chỉ khoản 11s-15s:
sh.Range("A6:i" & sh.[A1048576].End(xlUp).Row).Copy
ws.Range("A1").PasteSpecial xlPasteValues
cái tốc độ này có phải do máy tính không, hay do mình test sai?

 

[Hoàng Đình Huy]

Bạn ơi, mình giả lập 1 vùng dữ liệu toàn là số 1 từ vùng A1: I1048570 và sửa LastRw=sh.[A1048576].end(xlup).row.
So sánh tốc độ thì code mới khoản 20s, sao trong trường hợp này tốc độ lại chậm hơn khi dùng code cũ chỉ khoản 11s-15s:
sh.Range("A6:i" & sh.[A1048576].End(xlUp).Row).Copy
ws.Range("A1").PasteSpecial xlPasteValues
cái tốc độ này có phải do máy tính không, hay do mình test sai?

E dùng từ pivot paste qua thì e thấy code cũ chạy tầm 3 phút còn code mới chạy 0,1 phút ạ. E thấy cải thiện rõ rệt lắm ạ