Các câu hỏi về mảng trong VBA (Array)

viehoai · 24/3/11

Xin các anh chị giúp đỡ Code Gán các giá trị của một Range là các phần tử của Mãng
Ví dụ: Tôi có các giá trị của Range("A1:A10"). Tôi muốn viết code để gán giá trị của các cells từ A1:A10 là các phần tử của Mãng Arr chẳn hạn.
Xin cảm ơn các anh chị

ThuNghi · 18/2/12

ndu96081631 đã viết:
Vừa test xong dữ liệu 40000 dòng ---> Kết quả 2.5 giây
Ẹc... Ẹc... nhanh thật
Nhưng... cái này còn nhanh hơn nè:

PHP:

Sheets(WshName).UsedRange.ClearContents SrcRng.AdvancedFilter 2, .Range("K1:K2"), Sheets(WshName).Range("A1") Next End If .[K1:K2].Clear Application.ScreenUpdating = True MsgBox Timer - T End With End Sub

Advanced Filter cho kết quả trong vòng 1 giây

Mình cũng test lại, việc Clear cũng mất nhiều thời gian khi WB đã có sh tồn tại.
Thử dùng Arr 1 chiều thay thế ArrBP thì thấy tốc độ code NDU và mình cũng thời gian gần như nhau.

PHP:

Sub TonghopArr()
  Dim sArray, subArr(), Arr(), i As Long, Title, nR&, k&, n&
  Dim tmpR As Long, p As Long, lC As Long, keyArr, WshName As String
  Dim Dic As Object, Tmp As String, ArrBP()
  Dim T
  T = Timer
  Set Dic = CreateObject("Scripting.Dictionary")
  Application.ScreenUpdating = False
  With Sheets("Data")
    sArray = .Range("A5:E60000").Value
    Title = .Range("A4:E4").Value
  End With
  For i = 1 To UBound(sArray, 1)
    If Len(CStr(sArray(i, 2))) Then
      Tmp = CStr(sArray(i, 2))
      If Not Dic.Exists(Tmp) Then
        n = n + 1
        Dic.Add Tmp, n
        ReDim Preserve ArrBP(1 To n)
      End If
      nR = Dic.Item(Tmp)
      If Len(ArrBP(nR)) Then
        ArrBP(nR) = ArrBP(nR) & vbBack & i
      Else
        ArrBP(nR) = i
      End If
    End If
  Next
 For i = 1 To UBound(ArrBP)
    nR = 0
    Tmp = CStr(ArrBP(i))
    aSplit = Split(Tmp, vbBack)
    ReDim subArr(1 To UBound(aSplit) + 1, 1 To UBound(sArray, 2))
    For j = 0 To UBound(aSplit)
      nR = nR + 1
      For k = 1 To UBound(sArray, 2)
        subArr(nR, k) = sArray(aSplit(j), k)
      Next k
    Next j
    WshName = CStr(subArr(1, 2))
    If isValidWshName(WshName) Then
      If Not SheetExist(WshName) Then
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = WshName
      End If
    End If
    With Sheets(WshName)
      .UsedRange.ClearContents
      .Range("A1").Resize(, UBound(sArray, 2)).Value = Title
      .Range("A2").Resize(UBound(aSplit) + 1, UBound(sArray, 2)) = subArr
    End With
  Next i
  Application.ScreenUpdating = True
MsgBox Timer - T
End Sub

Cám ơn NDU. Đang tính vận dụng để làm tạo sổ cái (kế toán) liên tục. Còn vài vấn đề là số sh > 256 hay chạy tạo khoảng 50 sh thì nên save lại nữa.
Chỉ có điều sao code mình viết dài quá, Bác Cò và Bác Mỹ cứ chê hoài.

viehoai · 21/2/12

Kính nhờ các anh chị xem, giúp đỡ Bài #309
Cảm ơn các anh chị

ThuNghi · 21/2/12

viehoai đã viết:
Kính nhờ các anh chị xem, giúp đỡ Bài #309
Cảm ơn các anh chị

Cụ thể hơn 1 chút đi, sai file nào và tiêu chí là sao ở file ghepmang. Chưa hiểu yêu cầu.

viehoai · 21/2/12

ThuNghi đã viết:
Cụ thể hơn 1 chút đi, sai file nào và tiêu chí là sao ở file ghepmang. Chưa hiểu yêu cầu.

Trong file GhepMang bị lỗi khi dòng lệnh trong đoạn

PHP:

If k = 4 Then
    ArrKQ(s, k) = "=" & ArrV(j, k)
Else
    ArrKQ(s, k) = ArrV(j, k)
End If

Có thêm dấu "=", nếu bỏ nó thì không lỗi. Nghĩa là em muốn phần tử mãng gán với phép tính

ThuNghi · 21/2/12

viehoai đã viết:
Trong file GhepMang bị lỗi khi dòng lệnh trong đoạn

PHP:

If k = 4 Then ArrKQ(s, k) = "=" & ArrV(j, k) Else ArrKQ(s, k) = ArrV(j, k) End If

Có thêm dấu "=", nếu bỏ nó thì không lỗi. Nghĩa là em muốn phần tử mãng gán với phép tính

Hiểu rồi,
- if tìm cột D lấy 4 số lẻ cuối > 179 hay =0 thì giữ nguyên.
- If not thì lấy cột E tham chiếu với sh Data và lấy các cột còn lại.
Tôi để hay bỏ dấu = thì code vẫn chạy bình thường mà.
Đang tìm cách tối hưu code trên theo hướng Arr toàn bộ.

viehoai · 21/2/12

ThuNghi đã viết:
Hiểu rồi,
- if tìm cột D lấy 4 số lẻ cuối > 179 hay =0 thì giữ nguyên.
- If not thì lấy cột E tham chiếu với sh Data và lấy các cột còn lại.
Tôi để hay bỏ dấu = thì code vẫn chạy bình thường mà.
Đang tìm cách tối hưu code trên theo hướng Arr toàn bộ.

Anh thử thêm "=" và bỏ nó rồi test xem file này thử giúp em nhé

viehoai · 21/2/12

ThuNghi đã viết:
Hiểu rồi,
- if tìm cột D lấy 4 số lẻ cuối > 179 hay =0 thì giữ nguyên.
- If not thì lấy cột E tham chiếu với sh Data và lấy các cột còn lại.
Tôi để hay bỏ dấu = thì code vẫn chạy bình thường mà.
Đang tìm cách tối hưu code trên theo hướng Arr toàn bộ.

Dấu thập phân hệ thống "." và "," đã bị bao nhiêu lần, và đã giúp nhiều người rồi mà vẫn bị cái này lừa
Cảm ơn anh, bài viết này làm em mới để ý nó. Như thế này sẽ hết lỗi luôn

PHP:

ArrKQ(s, k) = "=" & Replace(ArrV(j, k) & "*" & KLdm, ",", ".")

Nhưng câu 2 bài #309 vẫn chưa được các anh chị giúp đỡ. Xin các anh chị giúp tiếp

ThuNghi · 22/2/12

viehoai đã viết:
Dấu thập phân hệ thống "." và "," đã bị bao nhiêu lần, và đã giúp nhiều người rồi mà vẫn bị cái này lừa
Cảm ơn anh, bài viết này làm em mới để ý nó. Như thế này sẽ hết lỗi luôn

PHP:

ArrKQ(s, k) = "=" & Replace(ArrV(j, k) & "*" & KLdm, ",", ".")

Nhưng câu 2 bài #309 vẫn chưa được các anh chị giúp đỡ. Xin các anh chị giúp tiếp

Dùng thêm 1 for thế Find => nR.

PHP:

Sub TaoKQ2()
Dim i&, j&, k&, s&, nR&
Dim MyRange, ArrV, ArrKQ
Dim KLdm$
MyRange = Sheet1.Range("A1:E9").Value
ReDim ArrKQ(1 To 30, 1 To UBound(MyRange, 2))
For i = 1 To UBound(MyRange, 1)
  If Val(Right(MyRange(i, 5), 4)) > 179 Or Val(Right(MyRange(i, 5), 4)) = 0 Then
    s = s + 1
    For k = 1 To UBound(MyRange, 2)
      ArrKQ(s, k) = MyRange(i, k)
    Next k
  Else
    KLdm = MyRange(i, 5)
    ArrV = Sheet2.Range("A1:D1000").Value
    For j = 1 To UBound(ArrV, 1)
      If ArrV(j, 1) = KLdm Then
        nR = j + 1
        Exit For
      End If
    Next j
    For j = nR To UBound(ArrV, 1)
      If Len(ArrV(j, 1)) = 0 Then
        s = s + 1
        For k = 1 To 3
          ArrKQ(s, k) = ArrV(j, k)
          ArrKQ(s, 4) = "=" & ArrV(j, 4)
          ArrKQ(s, 5) = KLdm
        Next k
      End If
      If Len(ArrV(j, 1)) > 0 Then Exit For
    Next j
  End If
Next i
If s Then
  Sheet1.Range("A15").Resize(s, UBound(ArrKQ, 2)).Value = ArrKQ
End If
Erase MyRange, ArrV, ArrKQ
End Sub

Nếu Find nhiều đối tượng thì dùng Dic đẩ lấy dữ liệu của sh 2.

LinDan · 28/2/12

Các bạn xem giùm tôi đoạn code này sai chỗ nào mà không thể chạy được(tôi đang bắt đầu học VBA, nếu thấy vấn đề đơn giản quá mong các bác đừng cuời nhé!)

PHP:

Sub btoan()
    Dim Vung, DL(), i As Long
    Set Vung = Range([A4], [G65000].End(xlUp)).Resize(, 8)
    DL = Vung.Value
    ReDim KQ(1 To UBound(DL, 1), 1 To 1)
        For i = 1 To UBound(DL, 1)
        If DL(i, 1) > 0 Then
            j = j + 1
        ElseIf DL(i, 3) <> "" Then
            m = Vung(i, 3).Row
            KQ(m, 1) = DL(m, 7) * DL(j, 6)
        End If
        [H4].Resize(m).Value = KQ
    Next
    
End Sub

ThuNghi · 28/2/12

LinDan đã viết:
Các bạn xem giùm tôi đoạn code này sai chỗ nào mà không thể chạy được(tôi đang bắt đầu học VBA, nếu thấy vấn đề đơn giản quá mong các bác đừng cuời nhé!)

PHP:

For i = 1 To UBound(DL, 1) If DL(i, 1) > 0 Then j = j + 1 ElseIf DL(i, 3) <> "" Then m = Vung(i, 3).Row KQ(m, 1) = DL(m, 7) * DL(j, 6) End If [H4].Resize(m).Value = KQ

Nếu if và elseif trên kg thỏa thì lấy m =? => [H4].Resize(m).Value = KQ kg gán dc.
Và bạn cũng nên nói cụ thể hơn là bạn cần gì. Nhìn file này thấy có vẻ quen, giống như của nick nào đó.

Sub bto1()
Dim KQ(), DL(), i As Long
DL = Range([A4], [G65000].End(xlUp)).Resize(, 8).Value
Dim kl As Double
ReDim KQ(1 To UBound(DL, 1), 1 To 1)
For i = 1 To UBound(DL, 1)
If DL(i, 1) > 0 Then
kl = DL(i, 6)
Else
If DL(i, 3) <> "" Then
KQ(i, 1) = DL(i, 7) * kl
End If
End If
Next
[H4].Resize(i - 1).Value = KQ
End Sub

nmhung49 · 28/2/12

Mình không biết bạn tính ra sau như bạn để đoạn code này [H4].Resize(m).Value = KQ
Ra ngoài vòng lặp là được

LinDan · 28/2/12

Mẫu biểu bài này tôi tải về từ diễn đàn, ý tôi muốn điền công thức tại mỗi công việc cho cột H bằng (=) cột FxG, nghĩa là vật tư = thi công x định mức ấy mà.

Tôi xin gửi file hiển thị kết quả, mong được các bác chỉ cho.

ThuNghi · 28/2/12

LinDan đã viết:
Mẫu biểu bài này tôi tải về từ diễn đàn, ý tôi muốn điền công thức tại mỗi công việc cho cột H bằng (=) cột FxG, nghĩa là vật tư = thi công x định mức ấy mà.

Tôi xin gửi file hiển thị kết quả, mong được các bác chỉ cho.

Code tôi đã làm trong bài trước. Và có sửa lại là
Nếu dòng 18, cụ thể C18 ="" thì sao thỏa. Vậy tôi sửa lại code như sau:

PHP:

Sub bto1()
 Dim KQ(), DL(), i As Long
 DL = Range([A4], [G65000].End(xlUp)).Resize(, 8).Value
 Dim kl As Double
 ReDim KQ(1 To UBound(DL, 1), 1 To 1)
 For i = 1 To UBound(DL, 1)
  If DL(i, 1) > 0 Then
    kl = DL(i, 6)
  Else
    If DL(i, 7) <> "" Then
      KQ(i, 1) = DL(i, 7) * kl
    End If
  End If
 Next
 [J4].Resize(i - 1).Value = KQ
 End Sub

ndu96081631 · 28/2/12

LinDan đã viết:
Mẫu biểu bài này tôi tải về từ diễn đàn, ý tôi muốn điền công thức tại mỗi công việc cho cột H bằng (=) cột FxG, nghĩa là vật tư = thi công x định mức ấy mà.

Tôi xin gửi file hiển thị kết quả, mong được các bác chỉ cho.

Công thức cho cell H4:

PHP:

=IF(C4="","",LOOKUP(10^15,$F$4:$F4)*LOOKUP(10^15,$G$4:$G4))

Kéo fill xuống! Khỏi code kiết chi cho mệt

LinDan · 28/2/12

Công thức nhìn choáng quá, tôi không hiểu cái này 10^15 là cái gì thế? phiền thày Ndu chỉ cho.

ndu96081631 · 28/2/12

LinDan đã viết:
Công thức nhìn choáng quá, tôi không hiểu cái này 10^15 là cái gì thế? phiền thày Ndu chỉ cho.

LOOKUP với giá trị tìm là số cực lớn (10^15) thì kết quả trả về sẽ là phần tử cuối cùng có giá trị trong mảng
Vậy thôi

LinDan · 28/2/12

Chán quá, không hiểu sao mảng khó thế nhìn các bác trên diễn đàn làm ngon thế mà khi lao vào làm mới thấy khó thật, hôm nay sưu tầm các bài trên diễn đàn về làm nhưng sai nhiều quá.

Tôi lấy thử bài toán nhỏ:
- Cột I = Cột H x Cột G (Thành tiền = đơn giá x khối lượng định mức)
- Thành tiền mỗi công việc = VL+NC+MTC

Tôi viết Code như sau, trình độ còi quá không biết sai kiến thức cơ bản ở chỗ nào mà không biết

PHP:

Sub Ttoan()
    Dim Vung, DL(), i As Long, Nhom As Long, CongViec As Long, Tmp1, Tmp2
    dongcuoi = [G65000].End(xlUp).Row
    Set Vung = Range("A4:I" & dongcuoi)
    DL = Vung.Value
    Range("I4:I" & dongcuoi).ClearContents
    ReDim KQ(1 To UBound(DL, 1), 1 To 1)
    For i = UBound(DL, 1) To 1 Step -1
        Tmp1 = Tmp1 + DL(i, 9)
        If DL(i, 1) = "" And DL(i, 2) = "" Then
            Nhom = i
            KQ(Nhom, 1) = Tmp1
            Tmp2 = Tmp1 + Tmp2
            Tmp1 = 0
        ElseIf DL(i, 1) <> "" Then
            CongViec = i
            KQ(CongViec, 1) = Tmp2
            Tmp2 = 0
        ElseIf DL(i, 3) <> "" Then
            DL(i, 9) = DL(i, 7) * DL(i, 8)
        End If
    Next
    [I4].Resize(UBound(DL, 1)).Value = KQ
End Sub

Nhìn các anh nmhung49, trungvdb, bạn hoamattroicoi làm veo veo mà thấy thẹn quá

ThuNghi · 29/2/12

LinDan đã viết:
Chán quá, không hiểu sao mảng khó thế nhìn các bác trên diễn đàn làm ngon thế mà khi lao vào làm mới thấy khó thật, hôm nay sưu tầm các bài trên diễn đàn về làm nhưng sai nhiều quá.

Tôi lấy thử bài toán nhỏ:
- Cột I = Cột H x Cột G (Thành tiền = đơn giá x khối lượng định mức)
- Thành tiền mỗi công việc = VL+NC+MTC

Tôi viết Code như sau, trình độ còi quá không biết sai kiến thức cơ bản ở chỗ nào mà không biết

PHP:

Sub Ttoan() Dim Vung, DL(), i As Long, Nhom As Long, CongViec As Long, Tmp1, Tmp2 dongcuoi = [G65000].End(xlUp).Row Set Vung = Range("A4:I" & dongcuoi) DL = Vung.Value Range("I4:I" & dongcuoi).ClearContents ReDim KQ(1 To UBound(DL, 1), 1 To 1) For i = UBound(DL, 1) To 1 Step -1 Tmp1 = Tmp1 + DL(i, 9) If DL(i, 1) = "" And DL(i, 2) = "" Then Nhom = i KQ(Nhom, 1) = Tmp1 Tmp2 = Tmp1 + Tmp2 Tmp1 = 0 ElseIf DL(i, 1) <> "" Then CongViec = i KQ(CongViec, 1) = Tmp2 Tmp2 = 0 ElseIf DL(i, 3) <> "" Then DL(i, 9) = DL(i, 7) * DL(i, 8) End If Next [I4].Resize(UBound(DL, 1)).Value = KQ End Sub

Nhìn các anh nmhung49, trungvdb, bạn hoamattroicoi làm veo veo mà thấy thẹn quá

Thấy kg nhờ mình nhưng nói thật là bạn nên đi từ từ, những bài for ngược này và tư duy hơi cao thì khoan đã.

PHP:

Sub Ttoan01()
    Dim KQ, DL(), i As Long, Tmp1 As Double, Tmp2 As Double
    dongcuoi = [G65000].End(xlUp).Row
    DL = Range("A4:H" & dongcuoi).Value
    Range("I4:I1000").ClearContents
    ReDim KQ(1 To UBound(DL, 1), 1 To 1)
    For i = UBound(DL, 1) To 1 Step -1
      If DL(i, 1) = "" And DL(i, 2) = "" Then
        If DL(i, 3) <> "" Then
          KQ(i, 1) = DL(i, 7) * DL(i, 8)
          Tmp1 = Tmp1 + KQ(i, 1)
        Else
          If DL(i, 4) <> "" Then
            KQ(i, 1) = Tmp1
            Tmp2 = Tmp2 + Tmp1
            Tmp1 = 0
          End If
        End If
      Else
        KQ(i, 1) = Tmp2
        Tmp2 = 0
      End If
    Next
    [K4].Resize(UBound(DL, 1)).Value = KQ
End Sub

nmhung49 · 29/2/12

LinDan đã viết:
Chán quá, không hiểu sao mảng khó thế nhìn các bác trên diễn đàn làm ngon thế mà khi lao vào làm mới thấy khó thật, hôm nay sưu tầm các bài trên diễn đàn về làm nhưng sai nhiều quá.

Tôi lấy thử bài toán nhỏ:
- Cột I = Cột H x Cột G (Thành tiền = đơn giá x khối lượng định mức)
- Thành tiền mỗi công việc = VL+NC+MTC

Tôi viết Code như sau, trình độ còi quá không biết sai kiến thức cơ bản ở chỗ nào mà không biết

PHP:

Sub TT()
Dim VungDL, Mahieu As Long, DVi As Long, iRow As Long
With Sheet1.Range("A4:I21")
    VungDL = .Value
For iRow = 1 To UBound(VungDL, 1)
    If VungDL(iRow, 2) <> "" Then
        Mahieu = iRow
    End If
    If VungDL(iRow, 4) <> "" And VungDL(iRow, 5) = "" Then
        DVi = iRow
    End If
    If VungDL(iRow, 3) <> "" Then
        VungDL(iRow, 9) = VungDL(iRow, 7) * VungDL(iRow, 8)
        VungDL(DVi, 9) = VungDL(iRow, 9) + VungDL(DVi, 9)
        VungDL(Mahieu, 9) = VungDL(iRow, 9) + VungDL(Mahieu, 9)
    End If
Next iRow
.Value = VungDL
End With
End Sub

Bạn có thể tham khảo cách này cũng được
To Lindan hồi xưa mình cũng nhưng bạn thôi từ từ nhen bạn

LinDan · 29/2/12

Tôi thử làm đi từ trên xuống dưới, kết quả ra gần như chuẩn nhưng không hiểu tại sao kết quả I4 lại sai, nhờ các bạn chỉ hộ tôi nguyên nhân

PHP:

Sub Ttoan()
    Dim Vung, DL(), i As Long, Nhom As Long, CongViec As Long, Tmp1, Tmp2, heso
    dongcuoi = [G65000].End(xlUp).Row
    Set Vung = Range("A4:I" & dongcuoi)
    DL = Vung.Value
    Range("I4:I" & dongcuoi).ClearContents
    ReDim KQ(1 To UBound(DL, 1), 1 To 1)
    For i = 1 To UBound(DL, 1)
        If DL(i, 1) <> "" Then
            CongViec = i
            Tmp2 = 0
        ElseIf DL(i, 1) = "" And DL(i, 3) = "" Then
            Nhom = i
            heso = DL(i, 7)
            Tmp2 = Tmp2 + Tmp1
            KQ(CongViec, 1) = Tmp2
            Tmp1 = 0
        ElseIf DL(i, 4) = "V" & ChrW(7853) & "t li" & ChrW(7879) & "u khác" Then
            DL(i, 9) = 15 / 100 * Tmp1
        ElseIf DL(i, 3) <> "" Then
            KQ(i, 1) = heso * DL(i, 7) * DL(i, 8)
            Tmp1 = KQ(i, 1) + Tmp1
            KQ(Nhom, 1) = Tmp1
        End If
    Next
    [I4].Resize(UBound(DL, 1)).Value = KQ
End Sub

Các câu hỏi về mảng trong VBA (Array)

Thành viên gắn bó

Hãy cho rồi sẽ nhận!

Thành viên gắn bó

Hãy cho rồi sẽ nhận!

Thành viên gắn bó

Hãy cho rồi sẽ nhận!

Thành viên gắn bó

File đính kèm

Thành viên gắn bó

Hãy cho rồi sẽ nhận!

Thành viên tiêu biểu

File đính kèm

Hãy cho rồi sẽ nhận!

Thành viên tích cực

Thành viên tiêu biểu

File đính kèm

Hãy cho rồi sẽ nhận!

Huyền thoại GPE

Thành viên tiêu biểu

Huyền thoại GPE

Thành viên tiêu biểu

File đính kèm

Hãy cho rồi sẽ nhận!

Thành viên tích cực

File đính kèm

Thành viên tiêu biểu

File đính kèm