Trang 5/5 đầuđầu 1 2 3 4 5
Hiển thị kết quả tìm kiếm từ 41 đến 42 trên tổng số: 42

Ðề tài: Giúp mình về dữ liệu lớn trong exel

  1. Trích Nguyên văn bởi HieuCD View Post
    chạy code nầy xem sao? không được là bỏ của chạy lấy người
    Code:
    Sub Vlookup()
    Dim Darr(), Sarr(), Arr(), Dic As Object, i As Long, RKQ As Long, R As Long, C As Integer, Tmp As String
    'Sheets("Phieu").Shapes("Rounded Rectangle 1").Visible = True
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    RKQ = Range("A3").CurrentRegion.Rows.Count - 1
    If RKQ < 4 Then
        MsgBox ("Khong co du lieu Ma de lay ten, thoat chuong trinh"): Exit Sub
    End If
    Set Dic = CreateObject("scripting.dictionary")
    Sarr = Range("A4").Resize(RKQ).Value
    ReDim Arr(1 To RKQ, 1 To 1)
    For i = 1 To RKQ
      Tmp = Sarr(i, 1)
      If Not Dic.exists(Tmp) Then
        Dic.Add Tmp, 1
        Dic.Add Tmp & "#" & 1, i
      Else
        k = Dic.Item(Tmp) + 1
        Dic.Item(Tmp) = k
        Dic.Add Tmp & "#" & k, i
      End If
    Next i
    
    
    Workbooks.Open Filename:=ThisWorkbook.Path & "\DULIEU.XLSX", ReadOnly:=True
    With ActiveWorkbook.Sheets("NNT")
      C = .Range("XX4").End(xlToLeft).Column
      R = .Range("A3").CurrentRegion.Rows.Count - 1
      Darr = .Range("A4").Resize(R, C).Value
    End With
    ActiveWorkbook.Close False
    For j = 1 To C Step 3
      For i = 1 To R
        Tmp = Darr(i, j)
        If Tmp = "" Then Exit For
        If Dic.exists(Tmp) Then
          For k = 1 To Dic.Item(Tmp)
            n = n + 1
            Arr(Dic.Item(Darr(i, j) & "#" & k), 1) = Darr(i, j + 1)
          Next k
          If n = RKQ Then GoTo Thoat
        End If
      Next i
    Next j
    Thoat:
    Range("B4").Resize(RKQ) = Arr
    'Sheets("Phieu").Shapes("Rounded Rectangle 1").Visible = False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    End Sub
    Code này đổi thuật toán --> cho phép tốc độ cải thiện đáng kể.

  2. Cảm ơn bạn Hiếu code chạy nhanh hơn rất nhiều.
    Trích Nguyên văn bởi HieuCD View Post
    chạy code nầy xem sao? không được là bỏ của chạy lấy người
    Code:
    Sub Vlookup()
    Dim Darr(), Sarr(), Arr(), Dic As Object, i As Long, RKQ As Long, R As Long, C As Integer, Tmp As String
    'Sheets("Phieu").Shapes("Rounded Rectangle 1").Visible = True
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    RKQ = Range("A3").CurrentRegion.Rows.Count - 1
    If RKQ < 4 Then
        MsgBox ("Khong co du lieu Ma de lay ten, thoat chuong trinh"): Exit Sub
    End If
    Set Dic = CreateObject("scripting.dictionary")
    Sarr = Range("A4").Resize(RKQ).Value
    ReDim Arr(1 To RKQ, 1 To 1)
    For i = 1 To RKQ
      Tmp = Sarr(i, 1)
      If Not Dic.exists(Tmp) Then
        Dic.Add Tmp, 1
        Dic.Add Tmp & "#" & 1, i
      Else
        k = Dic.Item(Tmp) + 1
        Dic.Item(Tmp) = k
        Dic.Add Tmp & "#" & k, i
      End If
    Next i
    
    
    Workbooks.Open Filename:=ThisWorkbook.Path & "\DULIEU.XLSX", ReadOnly:=True
    With ActiveWorkbook.Sheets("NNT")
      C = .Range("XX4").End(xlToLeft).Column
      R = .Range("A3").CurrentRegion.Rows.Count - 1
      Darr = .Range("A4").Resize(R, C).Value
    End With
    ActiveWorkbook.Close False
    For j = 1 To C Step 3
      For i = 1 To R
        Tmp = Darr(i, j)
        If Tmp = "" Then Exit For
        If Dic.exists(Tmp) Then
          For k = 1 To Dic.Item(Tmp)
            n = n + 1
            Arr(Dic.Item(Darr(i, j) & "#" & k), 1) = Darr(i, j + 1)
          Next k
          If n = RKQ Then GoTo Thoat
        End If
      Next i
    Next j
    Thoat:
    Range("B4").Resize(RKQ) = Arr
    'Sheets("Phieu").Shapes("Rounded Rectangle 1").Visible = False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    End Sub

Trang 5/5 đầuđầu 1 2 3 4 5

Thông tin về chủ đề này

Users Browsing this Thread

Hiện có 1 người đang xem đề tài này. (0 thành viên và 1 khách)

Bookmarks

Bookmarks

Quyền Sử Dụng Ở Diễn Ðàn

  • Bạn không thể đăng đề tài mới
  • Bạn không thể đăng trả lời
  • Bạn không thể đăng file đính kèm.
  • Bạn không thể sửa bài viết.
  •