Chuyên đề giải đáp những thắc mắc về code VBA

maytinhvp01 · 31/7/13

Mình muốn nhờ giải thich câu lệnh " If Ran.Cells(d, c) > max Then max = Ran.Cells(d, c) "
trong ví du:
Public Function LonNhat(Ran As Range)
Dim max As Double, v As Integer, d As Integer, c As Integer
max = Ran.Cells(1, 1)
For d = 1 To Ran.Rows.Count
For c = 1 To Ran.Columns.Count
If Ran.Cells(d, c) > max Then max = Ran.Cells(d, c)
Next c
Next d
v = Tim(max, Ran)
LonNhat = max
End Function
-------------------------------------------------------
[INFO1]Thông báo:
Vì topic này:
http://www.giaiphapexcel.com/forum/...ải-thích-các-code-đề-nghị-các-bạn-gửi-vào-đây
đã quá dài nên BQT đóng lại.
Nay tôi mở topic mới với cùng chủ đề: GIẢI THÍCH NHỮNG THẮC MẮC VỀ CODE
Các bạn nếu có nhu cầu giải thích code, vui lòng post tại đây nhé
NDU96081631
[/INFO1]

befaint · 13/1/21

NHN_Phương đã viết:
Hic, OT chưa biết gặp phải lỗi gì nhưng OT thử thấy 'ngon lành' mà Bạn.

Thử chọn A1:B3 xem..

Hoàng Nhật Phương · 13/1/21

befaint đã viết:
Thử chọn A1:B3 xem..

Đúng là nhân thêm với số cột ạ.
Hic,thực sự không đơn gian chút nào.

befaint · 13/1/21

NHN_Phương đã viết:
Đúng là nhân thêm với số cột ạ.
Hic,thực sự không đơn gian chút nào.

Có gì đâu mà không đơn giản.
Khúc lấy địa chỉ dòng thì thêm loại trùng vào là xong thôi.

Hoàng Nhật Phương · 13/1/21

befaint đã viết:
Có gì đâu mà không đơn giản.
Khúc lấy địa chỉ dòng thì thêm loại trùng vào là xong thôi.

OT thấy khó là vì có thể chỗ thì chọn một cột còn chỗ thì quét nhiều cột, không đồng nhất về số cột của mỗi vùng được lựa chọn ấy Bạn.

befaint · 13/1/21

NHN_Phương đã viết:
OT thấy khó là vì có thể chỗ thì chọn một cột còn chỗ thì quét nhiều cột, không đồng nhất về số cột của mỗi vùng được lựa chọn ấy Bạn.

Chiêu này gọi là chiêu thiên nga múa đó hả.

Chép cho dẻo tay nhé.

Hoàng Nhật Phương · 13/1/21

befaint đã viết:
Chiêu này gọi là chiêu thiên nga múa đó hả.

Chép cho dẻo tay nhé.

View attachment 252926

Ui, màn hình code của Bạn đẹp thật.
OT sẽ chép ạ, cảm ơn Bạn nhiều.

Hoàng Nhật Phương · 13/1/21

befaint đã viết:
Chiêu này gọi là chiêu thiên nga múa đó hả.

Chép cho dẻo tay nhé.

View attachment 252927

'Đại ca' ơi xem giúp 'em' lỗi này là lỗi gì vớii ạ :fish:

Mã:

Option Explicit

Sub ThemDong()
    Dim i As Long, r As Long, a As Variant
    Dim cell_ As Range, rng As Range
    If TypeName(Selection) <> "Range" Then Exit Sub
    Set rng = Selection
    Dim oArrList As Object
    Set oArrList = CreateObject("System.Collections.ArrayList")
    For Each cell_ In rng
        r = cell_.Row
        If oArrList.Contains(r) = False Then
            oArrList.Add r
        End If
    Next cell_
    If oArrList.Count = 0 Then Exit Sub
    oArrList.Sort
    a = oArrList.ToArray
    For i = UBound(a) To LBound(a) Step -1
        r = a(i)
        Rows(r & ":" & r).Copy
        Rows(r & ":" & r).Insert Shift:=xlUp
        Application.CutCopyMode = False
    Next i
    Set oArrList = Nothing: Erase a: Set rng = Nothing
End Sub

Hoàng Nhật Phương · 13/1/21

A! Được rồi, tuyệt vời cảm ơn Bạn @befaint ,
thì ra 'System.Collections.ArrayList' nó không thích hợp với 'NET 4.0' mà thích hợp với 'NET 3.5'

automation error -2146232576 (80131700) on creating an array

I have a macro that's working on one computer just fine, however when I try to run it on another computer I get the following error: Run-time error '-2146232576 (80131700)' Automation error Here'...

stackoverflow.com

Ơ nhưng mà nếu vậy thì code này nếu chuyển sang máy tính khác đang mặc định 'NET 4.0' thì sẽ không chạy được nếu không cài 'NET 3.5' ạ?

ptm0412 · 13/1/21

Thì xài Dictionary đi

Hoàng Nhật Phương · 13/1/21

ptm0412 đã viết:
Thì xài Dictionary đi

Chú Mỹ nay có hứng thú không ạ, chú chỉ giúp con cái xài 'Dictionary' 'cho chiêu thiên nga múa với vùng chọn này với chú Mỹ :

Mã:

Range("B3:D4,C6:J7,A9:E12").Select

Con thấy code của bạn @befaint xử lý được chiêu này rồi ạ.

ptm0412 · 13/1/21

NHN_Phương đã viết:
Con thấy code của bạn @befaint xử lý được chiêu này rồi ạ.

Học befaint còn chưa hết chiêu mà tham lam. Thế đã nhớ vụ "quay mông xinh xinh đi lùi" chưa?

Hoàng Nhật Phương · 13/1/21

ptm0412 đã viết:
Học befaint còn chưa hết chiêu mà tham lam. Thế đã nhớ vụ "quay mông xinh xinh đi lùi" chưa?

Vụ này chiều nay con cười xái cả quai hàm nên quên sao dễ được ạ. --=0

Hôm nay con còn biết thêm được nữa là code cần phải 'tét trong phòng thí nghiệm' nữa ahihi nẫu hết cả ruột.
Ai bảo chú gợi ý, mà khi đã còn cách là con sẽ phải cố xem cách nào nó tiện nhất vì không chỉ làm cho mỗi bản thân mình dùng mà còn cho người khác dùng để không làm phiền người khác, người khác cũng không gọi đến mình thì con chọn ạ.

ptm0412 · 13/1/21

NHN_Phương đã viết:
Ai bảo chú gợi ý, mà khi đã còn cách là con sẽ phải cố xem cách nào nó tiện nhất

Dictionary thua Collections.ArrayList vì ArrayList có phương thức sort, do đó Dict. phải chạy đường vòng và chậm hơn. Không hứng mấy nên chưa tối ưu

PHP:

Sub CopyInsertSelection()
Dim Dict, Arr()
Dim Cll As Range, i As Long, k As Long, lastRw As Long
Application.ScreenUpdating = False
lastRw = Cells(10000, 3).End(xlUp).Row
Set Dict = CreateObject("Scripting.Dictionary")
ReDim Arr(1 To lastRw, 1 To 1)
For Each Cll In Selection
    If Not Dict.exists(Cll.Row) Then
        Dict.Add Cll.Row, ""
        Arr(Cll.Row, 1) = Cll.Row
    End If
Next
For i = lastRw To 1 Step -1
    If Arr(i, 1) > 0 Then
        k = Arr(i, 1)
        Cells(k, 1).EntireRow.Copy
        Cells(k, 1).Insert Shift:=xlDown
    End If
Next
Set Dict = Nothing: Set Cll = Nothing: Erase Arr
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Hoàng Nhật Phương · 13/1/21

ptm0412 đã viết:

Dictionary thua Collections.ArrayList vì ArrayList có phương thức sort, do đó Dict. phải chạy đường vòng và chậm hơn. Không hứng mấy nên chưa tối ưu

PHP:

Sub CopyInsertSelection()
Dim Dict, Arr()
Dim Cll As Range, i As Long, k As Long, lastRw As Long
Application.ScreenUpdating = False
lastRw = Cells(10000, 3).End(xlUp).Row
Set Dict = CreateObject("Scripting.Dictionary")
ReDim Arr(1 To lastRw, 1 To 1)
For Each Cll In Selection
    If Not Dict.exists(Cll.Row) Then
        Dict.Add Cll.Row, ""
        Arr(Cll.Row, 1) = Cll.Row
    End If
Next
For i = lastRw To 1 Step -1
    If Arr(i, 1) > 0 Then
        k = Arr(i, 1)
        Cells(k, 1).EntireRow.Copy
        Cells(k, 1).Insert Shift:=xlDown
    End If
Next
Set Dict = Nothing: Set Cll = Nothing: Erase Arr
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Ơ, con mang code vào phòng thí nghiệm để tét với chiêu thiên nga múa các kiểu, kết quả tuyệt vời không kém gì phương pháp của Bạn @befaint chú Mỹ ơi .
Không có cảm giác chậm lắm chú Mỹ,thay vì phải xử lý từng dòng trên bảng tính thì kết hợp với Union gàn hết vào một thể xong rồi xử lý một lần được không chú Mỹ nhỉ?

ptm0412 · 13/1/21

NHN_Phương đã viết:
Ơ, con mang code vào phòng thí nghiệm để tét với chiêu thiên nga múa các kiểu, kết quả tuyệt vời không kém gì phương pháp của Bạn @befaint chú Mỹ ơi .
Không có cảm giác chậm lắm chú Mỹ,thay vì phải xử lý từng dòng trên bảng tính thì kết hợp với Union gàn hết vào một thể xong rồi xử lý một lần được không chú Mỹ nhỉ?

Không union được, Còn phương pháp thì giống y của bi phèn nhá! Chỉ khác công cụ và thủ thuật thôi nhá!
Trường hợp chậm là khi dữ liệu rất nhiều nhưng chỉ insert 1 số ít năm ba dòng

Hoàng Nhật Phương · 13/1/21

ptm0412 đã viết:
Không union được

Dạ vâng, vậy thôi chú Mỹ con chỉ mong chờ thêm xem nếu sử dụng được Union thì sẽ thế nào thôi ạ. Còn với cách nào nữa thì thôi ạ.. cách của chú Mỹ và của Bạn @befaint quá ổn rồi ạ.
Dạ thôi con xin phép đây, chú Mỹ tiếp tục múa đi nha

, con ngủ đây ạ,chúc chú Mỹ ngủ ngon.

HieuCD · 14/1/21

NHN_Phương đã viết:
Dạ vâng, vậy thôi chú Mỹ con chỉ mong chờ thêm xem nếu sử dụng được Union thì sẽ thế nào thôi ạ. Còn với cách nào nữa thì thôi ạ.. cách của chú Mỹ và của Bạn @befaint quá ổn rồi ạ.
Dạ thôi con xin phép đây, chú Mỹ tiếp tục múa đi nha , con ngủ đây ạ,chúc chú Mỹ ngủ ngon.

Dùng mảng lưu thứ tự dòng, tự thêm lệnh tăng tốc code ( application. )

Mã:

Sub ThemDong_ABC()
    
  Range("B3:D4,C6:J7,A9:E12").Select 'Test
  If TypeName(Selection) <> "Range" Then Exit Sub
 
  Dim fRow&, eRow&, i&
  Dim iRow As Range, Rng As Range, aRow() As Boolean
    
  Set Rng = Selection
  fRow = Rows.Count: eRow = 10 'Tuy hi?: 10>0
  ReDim aRow(1 To eRow)
  For Each iRow In Rng.Rows
    i = iRow.Row
    If i > eRow Then
      eRow = i
      If eRow > UBound(aRow) Then ReDim Preserve aRow(1 To eRow + 100) 'Tuy hi?: 100>=0
    End If
    If i < fRow Then fRow = i
    aRow(i) = True
  Next iRow
  For i = eRow To fRow Step -1
    If aRow(i) Then
      Rows(i & ":" & i).Insert Shift:=xlUp
      Rows(i + 1 & ":" & i + 1).Copy Rows(i & ":" & i)
    End If
  Next i
  Range("A" & i + 1).Select
  Erase aRow: Set Rng = Nothing: Set RngEx = Nothing: Set iRow = Nothing
End Sub

Hoàng Nhật Phương · 14/1/21

HieuCD đã viết:

Dùng mảng lưu thứ tự dòng, tự thêm lệnh tăng tốc code ( application. )

Mã:

Sub ThemDong_ABC()
   
  Range("B3:D4,C6:J7,A9:E12").Select 'Test
  If TypeName(Selection) <> "Range" Then Exit Sub

  Dim fRow&, eRow&, i&
  Dim iRow As Range, Rng As Range, aRow() As Boolean
   
  Set Rng = Selection
  fRow = Rows.Count: eRow = 10 'Tuy hi?: 10>0
  ReDim aRow(1 To eRow)
  For Each iRow In Rng.Rows
    i = iRow.Row
    If i > eRow Then
      eRow = i
      If eRow > UBound(aRow) Then ReDim Preserve aRow(1 To eRow + 100) 'Tuy hi?: 100>=0
    End If
    If i < fRow Then fRow = i
    aRow(i) = True
  Next iRow
  For i = eRow To fRow Step -1
    If aRow(i) Then
      Rows(i & ":" & i).Insert Shift:=xlUp
      Rows(i + 1 & ":" & i + 1).Copy Rows(i & ":" & i)
    End If
  Next i
  Range("A" & i + 1).Select
  Erase aRow: Set Rng = Nothing: Set RngEx = Nothing: Set iRow = Nothing
End Sub

Hay quá Bác ơi, bắt đầu con thấy trong con đã xuất hiện 'ReDim Preserve' ahihi.
Con cảm ơn Bác @HieuCD

tototolon_123 · 20/1/21

chào các anh chị. Em có file dữ liệu mà hiện tại có dòng lệnh này em vẫn chưa hiểu. Mong các anh chị giúp đỡ. Em là newbie. Đang tìm hiểu nên có gì anh chị chỉ dẫn giúp em nhé. Em cảm ơn ạ.
Sub InsertBottomRow(AccountFrame)
Set ARange = Range(AccountFrame)
Application.ScreenUpdating = False
ActiveSheet.Unprotect
CntRow = ARange.Rows.Count - 3
ARange.Rows(CntRow).EntireRow.Insert
ARange.Columns(1).Rows(CntRow).Activate
Range("AccountRow").Copy Destination:=ActiveCell
ActiveCell.Offset(0, 2).Value = Range(AccountFrame).Columns(1).Rows(1).Value
ActiveCell.Activate
ActiveSheet.Protect
Application.ScreenUpdating = True
End Sub

Sub InsertRowAtSelection(AccountFrame)
ActiveSheet.Unprotect
Application.ScreenUpdating = False
Set ARange = Range(AccountFrame)
CntRow = ARange.Rows.Count - 3

Set SRange = Range(Range(AccountFrame).Columns(1).Rows(3), Range(AccountFrame).Columns(15).Rows(CntRow))

If (Intersect(ActiveCell, SRange) Is Nothing) Then
MsgBox "Select a white cell within an account.", 0, "Wrong cell!"
Exit Sub
End If

Range("B" & (ActiveCell.Row)).Select
Selection.EntireRow.Insert
Range("AccountRow").Copy Destination:=ActiveCell
ActiveCell.Offset(0, 2).Value = Range(AccountFrame).Columns(1).Rows(1).Value
ActiveCell.Activate
ActiveSheet.Protect
Application.ScreenUpdating = True
End Sub

cái này dùng để thêm dòng vào một khoảng có trước mà em vẫn không làm được.

Maika8008 · 20/1/21

tototolon_123 đã viết:
chào các anh chị. Em có file dữ liệu mà hiện tại có dòng lệnh này em vẫn chưa hiểu. Mong các anh chị giúp đỡ. Em là newbie. Đang tìm hiểu nên có gì anh chị chỉ dẫn giúp em nhé. Em cảm ơn ạ.
Sub InsertBottomRow(AccountFrame)
Set ARange = Range(AccountFrame)
Application.ScreenUpdating = False
ActiveSheet.Unprotect
CntRow = ARange.Rows.Count - 3
ARange.Rows(CntRow).EntireRow.Insert
ARange.Columns(1).Rows(CntRow).Activate
Range("AccountRow").Copy Destination:=ActiveCell
ActiveCell.Offset(0, 2).Value = Range(AccountFrame).Columns(1).Rows(1).Value
ActiveCell.Activate
ActiveSheet.Protect
Application.ScreenUpdating = True
End Sub

Sub InsertRowAtSelection(AccountFrame)
ActiveSheet.Unprotect
Application.ScreenUpdating = False
Set ARange = Range(AccountFrame)
CntRow = ARange.Rows.Count - 3

Set SRange = Range(Range(AccountFrame).Columns(1).Rows(3), Range(AccountFrame).Columns(15).Rows(CntRow))

If (Intersect(ActiveCell, SRange) Is Nothing) Then
MsgBox "Select a white cell within an account.", 0, "Wrong cell!"
Exit Sub
End If

Range("B" & (ActiveCell.Row)).Select
Selection.EntireRow.Insert
Range("AccountRow").Copy Destination:=ActiveCell
ActiveCell.Offset(0, 2).Value = Range(AccountFrame).Columns(1).Rows(1).Value
ActiveCell.Activate
ActiveSheet.Protect
Application.ScreenUpdating = True
End Sub

cái này dùng để thêm dòng vào một khoảng có trước mà em vẫn không làm được.

Dòng nào không hiểu? "có dòng lệnh này em vẫn chưa hiểu" trong khi đưa cả tập lệnh mà không chỉ dòng nào là sao?

Chuyên đề giải đáp những thắc mắc về code VBA

Thành viên thường trực

|||||||||||||

Thành viên gắn bó

|||||||||||||

Thành viên gắn bó

|||||||||||||

Thành viên gắn bó

Thành viên gắn bó

Thành viên gắn bó

Bad Excel Member

Thành viên gắn bó

File đính kèm

Bad Excel Member

Thành viên gắn bó

Bad Excel Member

Thành viên gắn bó

Bad Excel Member

Thành viên gắn bó

Chuyên gia GPE

Thành viên gắn bó

Thành viên mới

Thành viên gạo cội

Đếm ngược thời gian