Nhờ các anh chị xem xét rút gọn công thức VBA giúp copy dữ liệu sang sheet khác

[Bigbangpham1]

Kính gửi các anh chị.

Em có nhu cầu chuyển 1 số dữ liệu từ sheet1 sang sheet 2.
Tuy nhiên khi kiến thức có hạn nên không viết được code tối ưu
Khi chạy báo lỗi nhưng tìm được nguyên nhân
Nhờ các anh chị tối ưu giúp file kèm theo.
Các nội dung mong muốn em đã viết trong file.
Em cảm ơn ạ

 

[HieuCD]

Kính gửi các anh chị.

Em có nhu cầu chuyển 1 số dữ liệu từ sheet1 sang sheet 2.
Tuy nhiên khi kiến thức có hạn nên không viết được code tối ưu
Khi chạy báo lỗi nhưng tìm được nguyên nhân
Nhờ các anh chị tối ưu giúp file kèm theo.
Các nội dung mong muốn em đã viết trong file.
Em cảm ơn ạ

Chạy code

Option Explicit
Sub XYZ()
  Dim arr(), res(), dic As Object
  Dim sRow&, sC&, i&, j&, k&, ik&, tg As Date, key$
  Const sCol& = 28 '(28-8)/2 = 10 lan trong 1 ngay
  Set dic = CreateObject("scripting.dictionary")
  With Sheets("Data")
    arr = .Range("A3", .Range("M" & Rows.Count).End(xlUp)).Value
  End With
  sRow = UBound(arr)
  ReDim res(1 To sRow, 1 To 100)
  For i = sRow To 1 Step -1
    If arr(i, 7) <> Empty Then
    tg = arr(i, 2)
    key = arr(i, 7) & "\" & CLng(Int(tg))
    If dic.exists(key) = False Then
      k = k + 1
      dic.Add key, k
      res(k, 2) = key
      res(k, 3) = arr(i, 7):  res(k, 4) = arr(i, 8)
      res(k, 5) = arr(i, 9):  res(k, 6) = arr(i, 11)
      res(k, 7) = arr(i, 12):  res(k, 8) = Int(tg)
    End If
    ik = dic.Item(key)
    For j = 9 To sCol Step 2
      If res(ik, j) = Empty Then
        res(ik, j) = Format(tg, "hh:mm")
        res(ik, j + 1) = arr(i, 13)
        If j > sC Then sC = j + 1
        Exit For
      End If
    Next j
    End If
  Next i
  Application.ScreenUpdating = False
  With Sheets("KQ")
    i = .Range("B" & Rows.Count).End(xlUp).Row
    If i > 10 Then .Range("A11:A" & i).Resize(, sCol).Clear
    If k Then
      .Range("C11").Resize(k).NumberFormat = "@"
      .Range("H11").Resize(k).NumberFormat = "dd-mm-yyyy"
      .Range("A11").Resize(k, sC).Borders.LineStyle = 1
      .Range("A11").Resize(k, sC) = res
      .Range("A11").Resize(k, sC).Sort .Range("C11"), 1, Header:=xlNo
      .Range("A11") = 1
      .Range("A11").Resize(k).DataSeries
    End If
  End With
  Application.ScreenUpdating = True
End Sub

 

[Bigbangpham1]

Chạy code

Option Explicit
Sub XYZ()
  Dim arr(), res(), dic As Object
  Dim sRow&, sC&, i&, j&, k&, ik&, tg As Date, key$
  Const sCol& = 28 '(28-8)/2 = 10 lan trong 1 ngay
  Set dic = CreateObject("scripting.dictionary")
  With Sheets("Data")
    arr = .Range("A3", .Range("M" & Rows.Count).End(xlUp)).Value
  End With
  sRow = UBound(arr)
  ReDim res(1 To sRow, 1 To 100)
  For i = sRow To 1 Step -1
    If arr(i, 7) <> Empty Then
    tg = arr(i, 2)
    key = arr(i, 7) & "\" & CLng(Int(tg))
    If dic.exists(key) = False Then
      k = k + 1
      dic.Add key, k
      res(k, 2) = key
      res(k, 3) = arr(i, 7):  res(k, 4) = arr(i, 8)
      res(k, 5) = arr(i, 9):  res(k, 6) = arr(i, 11)
      res(k, 7) = arr(i, 12):  res(k, 8) = Int(tg)
    End If
    ik = dic.Item(key)
    For j = 9 To sCol Step 2
      If res(ik, j) = Empty Then
        res(ik, j) = Format(tg, "hh:mm")
        res(ik, j + 1) = arr(i, 13)
        If j > sC Then sC = j + 1
        Exit For
      End If
    Next j
    End If
  Next i
  Application.ScreenUpdating = False
  With Sheets("KQ")
    i = .Range("B" & Rows.Count).End(xlUp).Row
    If i > 10 Then .Range("A11:A" & i).Resize(, sCol).Clear
    If k Then
      .Range("C11").Resize(k).NumberFormat = "@"
      .Range("H11").Resize(k).NumberFormat = "dd-mm-yyyy"
      .Range("A11").Resize(k, sC).Borders.LineStyle = 1
      .Range("A11").Resize(k, sC) = res
      .Range("A11").Resize(k, sC).Sort .Range("C11"), 1, Header:=xlNo
      .Range("A11") = 1
      .Range("A11").Resize(k).DataSeries
    End If
  End With
  Application.ScreenUpdating = True
End Sub

Vâng, em xin cảm ơn