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ị
Xin chào các bạn
Oanh Thơ đang sử dụng code sau để copy dữ liệu từ vùng "B799" của Sheet1
Sang vùng "E10" của sheet2:
Mã:
Sub CopyData()
Sheets("Sheet1").Range("B7:D99").Copy
Sheets("Sheet2").Range("E10").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
End Sub
Nhờ các bạn giúp đỡ cách viết khác sử dụng mảng ạ.
Xin chào các bạn
Oanh Thơ đang sử dụng code sau để copy dữ liệu từ vùng "B799" của Sheet1
Sang vùng "E10" của sheet2:
Mã:
Sub CopyData()
Sheets("Sheet1").Range("B7:D99").Copy
Sheets("Sheet2").Range("E10").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
End Sub
Nhờ các bạn giúp đỡ cách viết khác sử dụng mảng ạ.
Sub Doc_Ngang()
Dim sArr(), dArr(), i As Long, j&
sArr = Sheets("Sheet1").Range("B7:D99").Value
ReDim dArr(1 To UBound(sArr, 2), 1 To UBound(sArr))
For i = 1 To UBound(sArr)
For j = 1 To UBound(sArr, 2)
dArr(j, i) = sArr(i, j)
Next
Next
Sheets("sheet2").[E10].Resize(UBound(dArr), UBound(dArr, 2)) = dArr
End Sub
Sub Doc_Ngang()
Dim sArr(), dArr(), i As Long, j&
sArr = Sheets("Sheet1").Range("B7:D99").Value
ReDim dArr(1 To UBound(sArr, 2), 1 To UBound(sArr))
For i = 1 To UBound(sArr)
For j = 1 To UBound(sArr, 2)
dArr(j, i) = sArr(i, j)
Next
Next
Sheets("sheet2").[E10].Resize(UBound(dArr), UBound(dArr, 2)) = dArr
End Sub
Sub TransposeArr()
Dim Arr(), lRow As Long, lCols As Long
Arr = Range("B7:D99").Value
lRow = UBound(Arr, 1)
lCols = UBound(Arr, 2)
Range("E10").Resize(lCols, lRow).Value = Application.WorksheetFunction.Transpose(Arr)
End Sub
Sub TransposeArr()
Dim Arr(), lRow As Long, lCols As Long
Arr = Range("B7:D99").Value
lRow = UBound(Arr, 1)
lCols = UBound(Arr, 2)
Range("E10").Resize(lCols, lRow).Value = Application.WorksheetFunction.Transpose(Arr)
End Sub
Hàm WorksheetFunction nó có giới hạn của nó:
1. Text chỉ được khoảng 255 ký tự
2. Chỉ được khoảng 500 dòng
Các con số trên, tôi có thể sai một chút. Nhưng chuyện giới hạn là chuyện thực tế.
Thử vài ô với text dài xem.
Sub Doc_Ngang()
Dim sArr(), dArr(), i As Long, j&
sArr = Sheets("Sheet1").Range("B7:D99").Value
ReDim dArr(1 To UBound(sArr, 2), 1 To UBound(sArr))
For i = 1 To UBound(sArr)
For j = 1 To UBound(sArr, 2)
dArr(j, i) = sArr(i, j)
Next
Next
Sheets("sheet2").[E10].Resize(UBound(dArr), UBound(dArr, 2)) = dArr
End Sub
Cảm ơn anh @quanghai1969 và các bạn đã hỗ trợ,
Nhờ các bạn giúp Oanh Thơ trường hợp đưa dữ liệu của vùng màu vàng trong cột C sang vùng màu vàng trong cột G, cũng sử dụng mảng với ạ:
Sub chuyendulieu()
Dim arr, arr1
Dim i As Long, a As Long
arr = Sheet1.Range("c3:c7").Value
ReDim arr1(1 To UBound(arr, 1) * 5, 1 To 1)
a = 1
For i = 1 To UBound(arr, 1)
arr1(a, 1) = arr(i, 1)
a = a + 5
Next i
Sheet1.Range("h3").Resize(a, 1).Value = arr1
End Sub
Sub chuyendulieu()
Dim arr, arr1
Dim i As Long, a As Long
arr = Sheet1.Range("c3:c7").Value
ReDim arr1(1 To UBound(arr, 1) * 5, 1 To 1)
a = 1
For i = 1 To UBound(arr, 1)
arr1(a, 1) = arr(i, 1)
a = a + 5
Next i
Sheet1.Range("h3").Resize(a, 1).Value = arr1
End Sub
Cảm ơn bạn đã hỗ trợ, Oanh Thơ (OT) loay hoay mãi mà vẫn chưa ra.
Híc xem code của bạn không thấy dễ như Oanh nghĩ chút nào thì ra phải dùng ReDim và dùng 2 mảng mới xong.
Code của bạn chay đúng rồi, còn ô cuối cùng của trong cột G bị lỗi #NA ạ.
Cảm ơn bạn đã hỗ trợ, Oanh Thơ (OT) loay hoay mãi mà vẫn chưa ra.
Híc xem code của bạn không thấy dễ như Oanh nghĩ chút nào thì ra phải dùng ReDim và dùng 2 mảng mới xong.
Code của bạn chay đúng rồi, còn ô cuối cùng của trong cột G bị lỗi #NA ạ.
Cảm ơn bạn đã hỗ trợ, Oanh Thơ (OT) loay hoay mãi mà vẫn chưa ra.
Híc xem code của bạn không thấy dễ như Oanh nghĩ chút nào thì ra phải dùng ReDim và dùng 2 mảng mới xong.
Code của bạn chay đúng rồi, còn ô cuối cùng của trong cột G bị lỗi #NA ạ.
Cảm ơn bạn đã hỗ trợ, Oanh Thơ (OT) loay hoay mãi mà vẫn chưa ra.
Híc xem code của bạn không thấy dễ như Oanh nghĩ chút nào thì ra phải dùng ReDim và dùng 2 mảng mới xong.
Code của bạn chay đúng rồi, còn ô cuối cùng của trong cột G bị lỗi #NA ạ.
Code trên đếm a dư 1.
Đếm như vầy mới đúng:
a = 0
For i = 1 To UBound(arr, 1)
a = a + 1
arr1(a, 1) = arr(i, 1)
a = a + 4
Next i
Nhưng mà nó luộm thuộm lắm. Tính luôn chỉ số cho nó gọn:
For i = 1 To UBound(arr1, 1) Step
arr1((i - 1) * 5 + 1, 1) = arr(i, 1)
Next i
Xin chào các bạn,
Oanh Thơ sử dụng code của snow25, để chuyển dữ liệu từ cột C sang cột K:L
Cách chuyển cứ mỗi 1 dòng tại cột C thì tạo thành 5 dòng liên tục giống nhau tại cột K:L như ảnh kèm.
Mã:
Sub Chuyen_DL()
Dim i As Long, j As Long, a As Long, LastRow As Long
Dim sh As Worksheet, arr As Variant, arr1 As Variant
Set sh = ThisWorkbook.Worksheets("Sheet1")
LastRow = sh.Cells(sh.Rows.Count, "C").End(xlUp).Row
arr = sh.Range("C1:D" & LastRow).Value
ReDim arr1(1 To UBound(arr, 1) * 5, 1 To 2)
a = 0
For i = 1 To UBound(arr, 1)
a = a + 1
arr1(a, 1) = arr(i, 1): arr1(a, 2) = arr(i, 2)
a = a + 4
Next i
With sh.Range("K1").Resize(a, 2)
.Value = arr1
.SpecialCells(xlCellTypeBlanks).Value = "=R[-1]C"
.Value = .Value
End With
End Sub
hihi, khổ ghê OT cũng tìm rồi đó mà.
híc OT sẽ tìm tiếp và nghĩ tiếp ạ. @befaint biết link rồi thì trích cho OT tham khảo với.
Còn code trên cũng xài OK rồi nhưng OT muốn học và dùng mảng ạ.
Sub Chuyen_DL()
Dim Arr1(), Arr2(), i&, j&, a&, n&
With Sheets("Sheet1")
Arr1 = .Range("C1", .[D65536].End(3)).Value
ReDim Arr2(1 To UBound(Arr1, 1) * 5, 1 To UBound(Arr1, 2))
For i = 1 To UBound(Arr1, 1)
For n = 0 To 4
For j = 1 To UBound(Arr1, 2)
Arr2(a + n + 1, j) = Arr1(i, j)
Next
Next
a = a + 5
Next i
.[K1].Resize(UBound(Arr2), UBound(Arr2, 2)) = Arr2
End With
End Sub
Hàm WorksheetFunction nó có giới hạn của nó:
1. Text chỉ được khoảng 255 ký tự
2. Chỉ được khoảng 500 dòng
Các con số trên, tôi có thể sai một chút. Nhưng chuyện giới hạn là chuyện thực tế.
Thử vài ô với text dài xem.
hihi, khổ ghê OT cũng tìm rồi đó mà.
híc OT sẽ tìm tiếp và nghĩ tiếp ạ. @befaint biết link rồi thì trích cho OT tham khảo với.
Còn code trên cũng xài OK rồi nhưng OT muốn học và dùng mảng ạ.
Sub ChuyenDL()
Dim sArr(), dArr(), I As Long, Idx As Long, K As Long, J As Long, N As Long: N = 5
sArr = Range("C1", Range("C" & Rows.Count).End(xlUp)).Resize(, 2).Value
ReDim dArr(1 To UBound(sArr) * N, 1 To UBound(sArr, 2))
For I = 1 To UBound(sArr)
If sArr(I, 1) <> mpty Then
For Idx = 1 To N
K = K + 1
For J = 1 To UBound(sArr, 2)
dArr(K, J) = sArr(I, J)
Next J
Next Idx
End If
Next I
If K Then Range("K1").Resize(K, UBound(sArr, 2)) = dArr
End Sub
Xin cảm ơn anh, chị và các bạn đã giúp đỡ ạ.
Các code trên đều chạy ra kết quả OK rồi.
Trong trường hợp dữ liệu trả về trong cột K:L (dữ liệu cột C đưa sang cột L,dữ liệu cột D đưa sang cột K) như ảnh kèm thì code của @quanghai1969 và @♫ђöล♥ßล†♥†µ♫(ôi cái tên ..đẹp ^^) thì phải sửa như thế nào ạ?
Híc mong các bạn đừng hiểu nhầm ạ , OT đang học hỏi để biết cách tự điều chỉnh,chứ thực tế dữ liệu hiện tại đang không phải như vậy,nhưng cũng có thể sẽ gặp ạ.
Nếu các bạn có thời gian mong được các bạn chỉ dẫn ạ.
Code ngắn cũng có cái hay nhưng khó nhìn thuật toán trong code. Code dài lê thê nhìn thấy gớm nhưng cần điều chỉnh thì lại dễ hơn đối với những người chỉ dùng VBA trong công việc văn phòng hàng ngày. Người khéo sẽ biết chọn phương án phù hợp cho từng trường hợp mà.
Xin cảm ơn anh, chị và các bạn đã giúp đỡ ạ.
Các code trên đều chạy ra kết quả OK rồi.
Trong trường hợp dữ liệu trả về trong cột K:L (dữ liệu cột C đưa sang cột L,dữ liệu cột D đưa sang cột K) như ảnh kèm thì code của @quanghai1969 và @♫ђöล♥ßล†♥†µ♫(ôi cái tên ..đẹp ^^) thì phải sửa như thế nào ạ?
Híc mong các bạn đừng hiểu nhầm ạ , OT đang học hỏi để biết cách tự điều chỉnh,chứ thực tế dữ liệu hiện tại đang không phải như vậy,nhưng cũng có thể sẽ gặp ạ.
Nếu các bạn có thời gian mong được các bạn chỉ dẫn ạ.
Em chế nó ra thế này. Nhân tiện luyện mấy cái Anh @befaint chỉ
PHP:
Sub ChuyenDL()
Dim sArr(), dArr(), I As Long, Idx As Long, K As Long, J As Long, _
R As Long, C As Long, Jdx As Long, sRng As Range
Const N As Long = 5
Set sRng = Range("K1")
sArr = Range("C1", Range("C" & Rows.Count).End(xlUp)).Resize(, 2).Value
R = UBound(sArr, 1): C = UBound(sArr, 2)
If R > Rows.Count - sRng.Row Then
MsgBox "Hands On.com"
Exit Sub
End If
ReDim dArr(1 To R * N, 1 To C)
For I = 1 To UBound(sArr)
If sArr(I, 1) <> Empty Then
For Idx = 1 To N
K = K + 1: Jdx = 0
For J = C To 1 Step -1
Jdx = Jdx + 1: dArr(K, Jdx) = sArr(I, J)
Next J
Next Idx
End If
Next I
sRng.Resize(K, UBound(sArr, 2)) = dArr
End Sub
Em chế nó ra thế này. Nhân tiện luyện mấy cái Anh @befaint chỉ
PHP:
Sub ChuyenDL()
Dim sArr(), dArr(), I As Long, Idx As Long, K As Long, J As Long, R As Long, C As Long, Jdx As Long
Const N As Long = 5
sArr = Range("C1", Range("C" & Rows.Count).End(xlUp)).Resize(, 2).Value
R = UBound(sArr, 1): C = UBound(sArr, 2)
ReDim dArr(1 To R * N, 1 To C)
For I = 1 To UBound(sArr)
If sArr(I, 1) <> mpty Then
For Idx = 1 To N
K = K + 1: Jdx = 0
For J = C To 1 Step -1
Jdx = Jdx + 1: dArr(K, Jdx) = sArr(I, J)
Next J
Next Idx
End If
Next I
With Range("K1")
If K < Rows.Count - .Row Then
If K Then .Resize(K, UBound(sArr, 2)) = dArr
Else
MsgBox "Hands On.com"
End If
End With
End Sub
Xin chào ♫ђöล♥ßล†♥†µ♫,
Cảm ơn bạn rất nhiều, code bị lỗi dòng "If sArr(I, 1) <> mpty Then", OT sửa lại "If sArr(I, 1) <> Empty Then" thì OK rồi bạn ạ.
Chắc bạn sửa luôn trên này chưa thử code (OT thấy người nào giỏi giỏi cái gì đó có ích, thấy ngưỡng mộ quá ^^)
Xin cảm ơn anh, chị và các bạn đã giúp đỡ ạ.
Các code trên đều chạy ra kết quả OK rồi.
Trong trường hợp dữ liệu trả về trong cột K:L (dữ liệu cột C đưa sang cột L,dữ liệu cột D đưa sang cột K) như ảnh kèm thì code của @quanghai1969 và @♫ђöล♥ßล†♥†µ♫(ôi cái tên ..đẹp ^^) thì phải sửa như thế nào ạ?
Híc mong các bạn đừng hiểu nhầm ạ , OT đang học hỏi để biết cách tự điều chỉnh,chứ thực tế dữ liệu hiện tại đang không phải như vậy,nhưng cũng có thể sẽ gặp ạ.
Nếu các bạn có thời gian mong được các bạn chỉ dẫn ạ.
Thử code này, dữ liệu gì mà bắt đầu từ hàng 1, ngộ vậy, muốn từ hàng nào thì sửa trong code nhé:
Mã:
Public Sub Teo()
Dim Vung, Kq, I, J
Vung = Range([C2], [C50000].End(xlUp)).Resize(, 2)
ReDim Kq(1 To UBound(Vung) * 5, 1 To 2)
For I = 1 To UBound(Kq)
J = J + IIf(I Mod 5 = 1, 1, 0)
Kq(I, 2) = Vung(J, 1): Kq(I, 1) = Vung(J, 2)
Next I
[K2].Resize(UBound(Kq), 2) = Kq
End Sub
Thử code này, dữ liệu gì mà bắt đầu từ hàng 1, ngộ vậy, muốn từ hàng nào thì sửa trong code nhé:
Mã:
Public Sub Teo()
Dim Vung, Kq, I, J
Vung = Range([C2], [C50000].End(xlUp)).Resize(, 2)
ReDim Kq(1 To UBound(Vung) * 5, 1 To 2)
For I = 1 To UBound(Kq)
J = J + IIf(I Mod 5 = 1, 1, 0)
Kq(I, 2) = Vung(J, 1): Kq(I, 1) = Vung(J, 2)
Next I
[K2].Resize(UBound(Kq), 2) = Kq
End Sub
Xin chào @concogia ,
Cảm ơn bạn đã quan tâm và giúp đỡ dữ liệu Oanh Thơ gửi lên hiện thời mang tính minh họa mục đích để Oanh Thơ học hỏi về mảng và chắc chắn sau hi vọng sau sẽ ứng dụng được ít nhiều vào thực tế trong công việc ạ.
Không ngờ mảng lại tuyệt vời đến với đến vậy.Nhanh, nhanh quá!
Xin chào các bạn,
Tôi muốn gán vùng dữ liệu C1:O1 vào DataValidation/list cho ô A1 và tôi đã thử code dưới bị lỗi chưa biết cách, nhờ các bạn xem giúp.
Mã:
Sub TestValidation()
Dim ary As Variant
ary = Sheets("Sheet1").Range("C1:O1").Value
ary = Application.Transpose(ary)
With Sheets("Sheet1").Cells(1, 1).Validation
.Delete
.Add Type:=xlValidateList, Formula1:=Join(ary, ",")
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
Sheets("Sheet1").Cells(1, 2).Resize(UBound(ary)).Value = ary
End Sub
B1: Đánh số cách quãng các dòng lệnh & thêm các dòng lệnh để bẫy lỗi, như sau:
Mã:
Sub TestValidation()
Dim ary As Variant
On Error GoTo LoiCT
2 ary = Sheets("Sheet1").Range("C1:O1").Value
ary = Application.Transpose(ary)
4 With Sheets("Sheet1").Cells(1, 1).Validation
.Delete
6 .Add Type:=xlValidateList, Formula1:=Join(ary, ",")
.IgnoreBlank = True: .InCellDropdown = True
8 .InputTitle = "": .ErrorTitle = ""
.InputMessage = "": .ErrorMessage = ""
10 .ShowInput = True: .ShowError = True
End With
12 Sheets("Sheet1").Cells(1, 2).Resize(UBound(ary)).Value = ary
Err_: Exit Sub
LoiCT:
MsgBox Error, , Erl
Resume Err_
End Sub
B1.1 Chạy thử Code để biết gần đúng dòng nào bị lỗi & lỗi là gì
(Sau khi thực hiện, macro báo ta biết dòng 6 bị lỗi; Nhưng ta đang đánh số cách quãng, nên lỗi có thể ở dòng 5 hay 7 nữa kia
B1.2: Ta lại tìm đúng dòng bị lỗi bằng cách đánh lại chỉ là:
PHP:
Sub TestValidation()
Dim ary As Variant
On Error GoTo LoiCT
ary = Sheets("Sheet1").Range("C1:O1").Value
ary = Application.Transpose(ary)
With Sheets("Sheet1").Cells(1, 1).Validation
5 .Delete
6 .Add Type:=xlValidateList, Formula1:=Join(ary, ",")
7 .IgnoreBlank = True: .InCellDropdown = True
.InputTitle = "": .ErrorTitle = ""
.InputMessage = "": .ErrorMessage = ""
.ShowInput = True: .ShowError = True
End With
Sheets("Sheet1").Cells(1, 2).Resize(UBound(ary)).Value = ary
Err_: Exit Sub
LoiCT:
MsgBox Error, , Erl
Resume Err_
End Sub
Sau khi lặp lại B1.1 ta biết đúng dòng 6 bị lỗi & nội dung lỗi là gì.
B2: Tìm mã lỗi của nội dung lỗi & viết lại cách dòng lệnh để bẫy lỗi:
Bằng cách thay dòng lệnh
MsgBox Error, , Erl
bỡi dòng lệnh: MsgBox Err, , Error
Ta biết được Err => 5
Ta sửa lại các dòng lệnh bẫy lỗi như sau:
Mã:
' . . . '
Err_: Exit Sub
LoiCT:
If Err = 5 Then
Resume Err_
Else
Resume Next
End If
End Sub
Bạn thử tiếp tục tìm lỗi của đứa con tinh thần của bạn thử xem sao & chúc thành công!
Xin chào các bạn,
Tôi muốn gán vùng dữ liệu C1:O1 vào DataValidation/list cho ô A1 và tôi đã thử code dưới bị lỗi chưa biết cách, nhờ các bạn xem giúp.
Mã:
Sub TestValidation()
Dim ary As Variant
ary = Sheets("Sheet1").Range("C1:O1").Value
ary = Application.Transpose(ary)
With Sheets("Sheet1").Cells(1, 1).Validation
.Delete
.Add Type:=xlValidateList, Formula1:=Join(ary, ",")
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
Sheets("Sheet1").Cells(1, 2).Resize(UBound(ary)).Value = ary
End Sub
Cháu cảm ơn hai bác SA_DQ và Siwtom đã giúp cháu.
Nhờ vào các giải thích chi tiết cháu cũng đã hiểu thêm một chút về mảng là như thế nào.
Hiện cháu đang loay hoay, khi gán dữ liệu mảng rồi,ví dụ:
thì làm thế nào để sử dụng các vòng lặp duyệt từng phần tử trong mảng 2 chiều để trả về mảng 1 chiều mà không phải sử dụngTranspose(ary)
nữa ạ.
Nếu hai bác và các bạn có hứng thú thời gian góp ý cho cháu thêm những cách để cháu tham khảo thêm ạ.
Xin chào các bạn,
Nhờ các bạn giúp đỡ cho tôi trường hợp sau với, làm thế nào để có thể gán được các con số như trong list tại ô A1, với điều kiện:
Các con số được lấy trong vùng "C1:O1" (vấn đề đã được xử lý ở bài 1052),
Nhưng thêm 1 điều kiện rút ngắn list lại, loại bỏ những cột(list) không có số liệu trong vùng "C2:O12"
Xin chào các bạn,
Nhờ các bạn giúp đỡ cho tôi trường hợp sau với, làm thế nào để có thể gán được các con số như trong list tại ô A1, với điều kiện:
Các con số được lấy trong vùng "C1:O1" (vấn đề đã được xử lý ở bài 1052),
Nhưng thêm 1 điều kiện rút ngắn list lại, loại bỏ những cột(list) không có số liệu trong vùng "C2:O12"
Sub TestValidation()
Dim ary As Variant, i As Long
ary = Sheets("Sheet1").Range("C1:O1").Value
For i = 1 To UBound(ary, 2)
If WorksheetFunction.CountA(Sheet1.Cells(2, 2 + i).Resize(10, 1)) = 0 Then
ary(1, i) = Empty
End If
Next i
ary = Application.Transpose(ary)
Sheets("Sheet1").Cells(1, "B").Resize(UBound(ary)).Value = ary
ary = Application.Transpose(ary)
With Sheets("Sheet1").Cells(1, "A").Validation
.Delete
.Add Type:=xlValidateList, Formula1:=Join(ary, ",")
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End Sub
Hiện cháu đang loay hoay, khi gán dữ liệu mảng rồi,ví dụ:
thì làm thế nào để sử dụng các vòng lặp duyệt từng phần tử trong mảng 2 chiều để trả về mảng 1 chiều mà không phải sử dụngTranspose(ary) nữa ạ.
Trong code tổng quát thì phải lường được dữ liệu để xem dữ liệu có có không, có thể chỉ là 1 giá trị hay luôn là mảng ... Vd. Muốn tuồn các giá trị từ B2 tới ô cuối cùng không trống trong cột B vào mảng. Có thể sẩy ra trường hợp không có dữ liệu (từ B2 trở đi đều trống), chỉ có 1 ô (B2<>"" và từ B3 là trống), và nhiều ô. Nhưng nếu muốn tuồn từ B2:C2 tới "cuối" thì chỉ sẩy ra 2 trường hợp: hoặc không có dữ liệu hoặc nhiều ô (ít nhất là 1 dòng tuồn vào mảng, mà dòng Bk:Ck luôn có 2 ô)
---------
Theo bạn thì code tuồn cứng nhắc một vùng có nhiều ô vào mảng nên ta cũng không kiểm tra mà biết ngay ary là mảng 2 chiều có 1 dòng và nhiều cột. Vậy ta duyệt mảng theo dòng.
Mã:
Sub test()
Dim c As Long, result(), ary, s As String
ary = Sheets("Sheet1").Range("C1:O1").Value
ReDim result(1 To UBound(ary, 2))
For c = 1 To UBound(ary, 2) ' To UBound(result)
result(c) = ary(1, c)
Next c
s = Join(result, ",")
MsgBox s
End Sub
Sub TestValidation()
Dim ary As Variant, i As Long
ary = Sheets("Sheet1").Range("C1:O1").Value
For i = 1 To UBound(ary, 2)
If WorksheetFunction.CountA(Sheet1.Cells(2, 2 + i).Resize(10, 1)) = 0 Then
ary(1, i) = Empty
End If
Next i
ary = Application.Transpose(ary)
Sheets("Sheet1").Cells(1, "B").Resize(UBound(ary)).Value = ary
ary = Application.Transpose(ary)
With Sheets("Sheet1").Cells(1, "A").Validation
.Delete
.Add Type:=xlValidateList, Formula1:=Join(ary, ",")
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End Sub
Xin chào snow25,
Cảm ơn bạn đã tham gia & giúp đỡ, OT vừa mới test code trên trả về kết quả đúng với mong muốn của Oanh Thơ rồi.
Tuy nhiên khi sử dụng mảng, nhờ snow25 và các bạn có thể làm thể nào để không phải sử dụng đến:
1.WorksheetFunction (đại loại vòng lặp không can thiệp vào Range)
2.Transpose (hay là giới hạn ký tự)
3.Loại bỏ các phần tử rỗng (Empty) , ví dụ trong hình ảnh tại bài 1056 (Oanh Thơ đưa lên) làm thế nào khi mà trả về mảng 1 chiếu cuối cùng thì các phần tử trong mảng chỉ chưa 7 phần tử thay vì đưa cả 13 phần tử vào (bao gồm cả rỗng). Tương tự cụ thể làm sao, để:
Không có các ô trống xen kẽ ạ.
Qua việc tự tìm hiểu (có thể là là sai ạ) OT thơ nghĩ trường hợp 3 cần có sự tham gia của Dictionary thì có thể giải quyết được?
Nếu đúng nhờ snow25 và các bạn giúp đỡ OT một đoạn code sử dụng kết hợp Dictionary để OT thấy được sự liên quan ạ.
Trong code tổng quát thì phải lường được dữ liệu để xem dữ liệu có có không, có thể chỉ là 1 giá trị hay luôn là mảng ... Vd. Muốn tuồn các giá trị từ B2 tới ô cuối cùng không trống trong cột B vào mảng. Có thể sẩy ra trường hợp không có dữ liệu (từ B2 trở đi đều trống), chỉ có 1 ô (B2<>"" và từ B3 là trống), và nhiều ô. Nhưng nếu muốn tuồn từ B2:C2 tới "cuối" thì chỉ sẩy ra 2 trường hợp: hoặc không có dữ liệu hoặc nhiều ô (ít nhất là 1 dòng tuồn vào mảng, mà dòng Bk:Ck luôn có 2 ô)
---------
Theo bạn thì code tuồn cứng nhắc một vùng có nhiều ô vào mảng nên ta cũng không kiểm tra mà biết ngay ary là mảng 2 chiều có 1 dòng và nhiều cột. Vậy ta duyệt mảng theo dòng.
Mã:
Sub test()
Dim c As Long, result(), ary, s As String
ary = Sheets("Sheet1").Range("C1:O1").Value
ReDim result(1 To UBound(ary, 2))
For c = 1 To UBound(ary, 2) ' To UBound(result)
result(c) = ary(1, c)
Next c
s = Join(result, ",")
MsgBox s
End Sub
Rất chi tiết,cơ bản và dễ hiểu đối cho những người mới tiếp xúc đến mảng như cháu, hihi hóa ra LBound là con số bắt đầu và Ubound là con số kết thúc trong mảng.
Mảng trừu tượng thật đó,nếu không hiểu bản chất thì rất khó ứng dụng được. Giờ cháu mới thấy được phần nào về cái hay của mảng và hiểu được tại sao khi anh @viehoai code vba ầm ầm như vậy mà vẫn còn thắc mắc đến mảng với anh ý còn như vậy thì không đối với người chậm hiểu và nhanh quên cháu không biết sẽ khi nào nữa. ~^^~
FOR.. cháu luôn hiểu là từ khóa của vòng lặp nên khi viết thì cứ nghĩ là "ÉpPhờ-O-RỜ" nên viết theo ạ,cháu không mấy khi để ý đến cách phát âm và nếu có phát âm thì cháu sẽ phát âm là Pho ạ
' có 2 ranges, rg1 và rg2. Tạo một mảng lớn với dữ liệu từ 2 ranges này
Dim mang, mangPhu
Dim soCot as Long, soDong as Long, i as Long, j as long
soCot = Application.Max(rg1.columns.count, rg2.columns.count) ' số cột bắt buộc phải là số lớn giữa 2 ranges
soDong = rg1.rows.count + rg2.rows.count ' số dòng là tổng 2 ranges
mang = rg1.Resize(soDong, soCot).Value ' chép rg1 vào mảng, với số dòng dư
mangPhu = rg2.Resize(, soCot).Value ' chép rg2 vào mảng phụ
soDong = rg1.rows.count ' bắt đầu chép mảng phụ vào mảng chính
For i = 1 to rg2.rows.count
soDong = soDong + 1
For j = 1 to soCot
mang(soDong, j) = mangPhu(i, j)
Next j
Next i
Anh ơi cách này của em có gì sai mà mảng kết quả không đủ nhỉ
PHP:
Sub Xep_hang_CaNhan_2018()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
With Sheets("Data")
Dim mang, mangPhu
Dim soCot As Long, soDong As Long, i As Long, j As Long
Dim rg1 As Range, rg2 As Range
mang = .Range("B6:F5000").Value2
mangPhu = .Range("FE6:FO5000").Value2
For i = 1 To UBound(mang, 1)
For j = 7 To 17
ReDim Preserve mang(1 To UBound(mang, 1), 1 To j)
mang(i, j) = mangPhu(i, j - 6)
Next j
Next i
End With
Sheets("cham chi").Range("V1").Resize(UBound(mang, 1), UBound(mang, 2)) = mang
End Sub
Em thấy nó lấy đến cột F của mảng mang, tiếp theo cột trống, tiếp theo nữa là dữ liệu cột FE, sau đó thì lại trống hoàn toàn. Kiểm tra số cột thì đúng bằng 17 như em chỉ định ở vòng lặp j.
Anh ơi cách này của em có gì sai mà mảng kết quả không đủ nhỉ
PHP:
Sub Xep_hang_CaNhan_2018()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
With Sheets("Data")
Dim mang, mangPhu
Dim soCot As Long, soDong As Long, i As Long, j As Long
Dim rg1 As Range, rg2 As Range
mang = .Range("B6:F5000").Value2
mangPhu = .Range("FE6:FO5000").Value2
For i = 1 To UBound(mang, 1)
For j = 7 To 17
ReDim Preserve mang(1 To UBound(mang, 1), 1 To j)
mang(i, j) = mangPhu(i, j - 6)
Next j
Next i
End With
Sheets("cham chi").Range("V1").Resize(UBound(mang, 1), UBound(mang, 2)) = mang
End Sub
Em thấy nó lấy đến cột F của mảng mang, tiếp theo cột trống, tiếp theo nữa là dữ liệu cột FE, sau đó thì lại trống hoàn toàn. Kiểm tra số cột thì đúng bằng 17 như em chỉ định ở vòng lặp j.
For i = 1 To UBound(mang, 1)
For j = 7 To 17
ReDim Preserve mang(1 To UBound(mang, 1), 1 To j)
Bạn đã ReDim Preserve mang tất cả 11*4995 lần
Trong khi chỉ cần 1 lần đã đạt kết quả
ReDim Preserve mang(1 To UBound(mang, 1), 1 To 17)
For i = 1 To UBound(mang, 1)
For j = 7 To 17
2. dữ liệu bị mất vì lý do này:
For i = 1 To UBound(mang, 1) ' khi i = 1, vòng lặp kế tiếp chép dữ liệu vào cột 7 đến 17 của dòng 1
For j = 7 To 17
ReDim Preserve mang(1 To UBound(mang, 1), 1 To j) ' khi i = 2, và j = 7, lệnh trên đặt lại số cột là 7 cho nên nó xoá cột 8-17 của dòng 1
' khi i = 3, và j = 7, lệnh trên xoá cột 8-17 của dòng 1 và 2
' tức là cứ mỗi lượt thì dòng trước bị xoá.
Mục đích của mình chỉ là gộp mảng Phụ vào mảng "mang". Dữ liệu nhiều cột quá lại cách xa nhau nên mình làm thế cho mảng đỡ lớn. Và chủ yếu muốn học hỏi thêm.
For i = 1 To UBound(mang, 1)
For j = 7 To 17
ReDim Preserve mang(1 To UBound(mang, 1), 1 To j)
Bạn đã ReDim Preserve mang tất cả 11*4995 lần
Trong khi chỉ cần 1 lần đã đạt kết quả
ReDim Preserve mang(1 To UBound(mang, 1), 1 To 17)
For i = 1 To UBound(mang, 1)
For j = 7 To 17
2. dữ liệu bị mất vì lý do này:
For i = 1 To UBound(mang, 1) ' khi i = 1, vòng lặp kế tiếp chép dữ liệu vào cột 7 đến 17 của dòng 1
For j = 7 To 17
ReDim Preserve mang(1 To UBound(mang, 1), 1 To j) ' khi i = 2, và j = 7, lệnh trên đặt lại số cột là 7 cho nên nó xoá cột 8-17 của dòng 1
' khi i = 3, và j = 7, lệnh trên xoá cột 8-17 của dòng 1 và 2
' tức là cứ mỗi lượt thì dòng trước bị xoá.
Vậy em hơi hiểu về cái Redim Preserve rồi. Nhờ anh chỉ dẫn em đã hoàn thiện lại code chạy cho kết quả đúng và nhanh không tưởng so với lúc trước vừa thiếu vừa lâu. Chắc là do nguyên nhân anh bảo "Bạn đã ReDim Preserve mang tất cả 11*4995 lần"
Cảm ơn anh nhé, em chúc anh ngày cuối tuần vui vẻ!
PHP:
Sub Xep_hang_CaNhan_2018()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
With Sheets("Data")
Dim mang, mangPhu
Dim soCot As Long, soDong As Long, i As Long, j As Long
Dim rg1 As Range, rg2 As Range
mang = .Range("B6:F5000").Value2
mangPhu = .Range("FE6:FO5000").Value2
ReDim Preserve mang(1 To UBound(mang, 1), 1 To 16)
For i = 1 To UBound(mang, 1)
For j = 6 To 16
mang(i, j) = mangPhu(i, j - 5)
Next j
Next i
End With
Sheets("cham chi").Range("V5").Resize(UBound(mang, 1), UBound(mang, 2)) = mang
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Dim soCot1 As Integer, soCot2 As Integer
mang = .Range("B6:F5000").Value2
mangPhu = .Range("FE6:FO5000").Value2
soCot1 = UBound(mang,2)
soCot2 = UBound(mangPhu,2)
ReDim Preserve mang(1 To UBound(mang, 1), 1 To soCot1 + soCot2)
For i = 1 To UBound(mang, 1)
For j = 1 To soCot2
mang(i, soCot1 + j) = mangPhu(i, j)
Next j
Next i
Dim soCot1 As Integer, soCot2 As Integer
mang = .Range("B6:F5000").Value2
mangPhu = .Range("FE6:FO5000").Value2
soCot1 = UBound(mang,2)
soCot2 = UBound(mangPhu,2)
ReDim Preserve mang(1 To UBound(mang, 1), 1 To soCot1 + soCot2)
For i = 1 To UBound(mang, 1)
For j = 1 To soCot2
mang(i, soCot1 + j) = mangPhu(i, j)
Next j
Next i
Chào mọi người, Mình có 10 mảng, khai báo từ sArr1 - sArr10, cấu trúc mảng như nhau, và mục đích dùng "Scripting.Dictionary" để lấy giá trị duy nhất của cả 10 mảng
Mã:
sArr1 = Sheets("B1").Range("K5", Sheets("B1").Range("K99999").End(xlUp)).Resize(, 3).Value
sArr2 = Sheets("B2").Range("K5", Sheets("B2").Range("K99999").End(xlUp)).Resize(, 3).Value
.... Cho den sArr10
và đoạn code sau:
For i = 1 To UBound(sArr1)
Tem = sArr1(i, 1) & "MAO" & sArr1(i, 2) '& "MAO" & sArr1(i, 3)
If sArr1(i, 2) <> "" Then
If Not dic.exists(Tem) Then
dic.Add Tem, sArr1(i, 3)
End If
End If
Next i
Vậy có cách nào để không phải viết lại 10 lần vòng lặp này (Thay thành sArr2, sArr3....) ko vậy. Xin cảm ơn mọi người !
Chào mọi người, Mình có 10 mảng, khai báo từ sArr1 - sArr10, cấu trúc mảng như nhau, và mục đích dùng "Scripting.Dictionary" để lấy giá trị duy nhất của cả 10 mảng
Mã:
sArr1 = Sheets("B1").Range("K5", Sheets("B1").Range("K99999").End(xlUp)).Resize(, 3).Value
sArr2 = Sheets("B2").Range("K5", Sheets("B2").Range("K99999").End(xlUp)).Resize(, 3).Value
.... Cho den sArr10
và đoạn code sau:
For i = 1 To UBound(sArr1)
Tem = sArr1(i, 1) & "MAO" & sArr1(i, 2) '& "MAO" & sArr1(i, 3)
If sArr1(i, 2) <> "" Then
If Not dic.exists(Tem) Then
dic.Add Tem, sArr1(i, 3)
End If
End If
Next i
Vậy có cách nào để không phải viết lại 10 lần vòng lặp này (Thay thành sArr2, sArr3....) ko vậy. Xin cảm ơn mọi người !
Chào mọi người, Mình có 10 mảng, khai báo từ sArr1 - sArr10, cấu trúc mảng như nhau, và mục đích dùng "Scripting.Dictionary" để lấy giá trị duy nhất của cả 10 mảng
Mã:
sArr1 = Sheets("B1").Range("K5", Sheets("B1").Range("K99999").End(xlUp)).Resize(, 3).Value
sArr2 = Sheets("B2").Range("K5", Sheets("B2").Range("K99999").End(xlUp)).Resize(, 3).Value
.... Cho den sArr10
và đoạn code sau:
For i = 1 To UBound(sArr1)
Tem = sArr1(i, 1) & "MAO" & sArr1(i, 2) '& "MAO" & sArr1(i, 3)
If sArr1(i, 2) <> "" Then
If Not dic.exists(Tem) Then
dic.Add Tem, sArr1(i, 3)
End If
End If
Next i
Vậy có cách nào để không phải viết lại 10 lần vòng lặp này (Thay thành sArr2, sArr3....) ko vậy. Xin cảm ơn mọi người !
Nhưng tạo 10 mảng làm gì khi ở mỗi thời điểm chỉ dùng 1 mảng?
Ngoài ra code không xử lý trường hợp khi ô cuối cùng ở cột K nằm ở dòng < 5. Lúc đó cũng cho vd. K4 & "MAO" & L4 vào đít to?
Tham khảo (tôi viết chay vì lười tạo dữ liệu để test)
Mã:
Sub test()
Dim lastRow As Long, k As Long, r As Long, Arr(), tem As String, dic As Object
Set dic = CreateObject("Scripting.Dictionary")
For k = 1 To 10
With ThisWorkbook.Worksheets("B" & k)
lastRow = .Cells(Rows.Count, "K").End(xlUp).Row
If lastRow >= 5 Then
Arr = .Range("K5:K" & lastRow).Resize(, 3).Value
For r = 1 To UBound(Arr)
If Len(Arr(r, 2)) Then
tem = Arr(r, 1) & "MAO" & Arr(r, 2)
If Not dic.exists(tem) Then dic.Add tem, Arr(r, 3)
End If
Next r
End If
End With
Next k
' lam gi do voi dic
' ...
Set dic = Nothing
End Sub
Nhưng tạo 10 mảng làm gì khi ở mỗi thời điểm chỉ dùng 1 mảng?
Ngoài ra code không xử lý trường hợp khi ô cuối cùng ở cột K nằm ở dòng < 5. Lúc đó cũng cho vd. K4 & "MAO" & L4 vào đít to?
Tham khảo (tôi viết chay vì lười tạo dữ liệu để test)
Mã:
Sub test()
Dim lastRow As Long, k As Long, r As Long, Arr(), tem As String, dic As Object
Set dic = CreateObject("Scripting.Dictionary")
For k = 1 To 10
With ThisWorkbook.Worksheets("B" & k)
lastRow = .Cells(Rows.Count, "K").End(xlUp).Row
If lastRow >= 5 Then
Arr = .Range("K5:K" & lastRow).Resize(, 3).Value
For r = 1 To UBound(Arr)
If Len(Arr(r, 2)) Then
tem = Arr(r, 1) & "MAO" & Arr(r, 2)
If Not dic.exists(tem) Then dic.Add tem, Arr(r, 3)
End If
Next r
End If
End With
Next k
' lam gi do voi dic
' ...
Set dic = Nothing
End Sub
Xin chào các bạn,
Oanh Thơ (OT) đang sử dụng sub CompareWorksheets, với mục đích so sánh dữ liệu của 2 bảng tính tìm ra những ô khác nhau và ghi lại kết quả khác nhau ra một sheet khác:
Mã:
Public Sub CompareWorksheets(ws1 As Worksheet, ws2 As Worksheet)
Dim lr1 As Long, lr2 As Long, lc1 As Integer, lc2 As Integer
Dim maxR As Long, maxC As Integer, cf1 As String, cf2 As String
Dim DiffCount As Long, r As Long, c As Integer
lr1 = ws1.UsedRange.Rows.count: lc1 = ws1.UsedRange.Columns.count
lr2 = ws2.UsedRange.Rows.count: lc2 = ws2.UsedRange.Columns.count
maxR = lr1: maxC = lc1
If maxR < lr2 Then maxR = lr2: If maxC < lc2 Then maxC = lc2
DiffCount = 0
For c = 1 To maxC
Application.StatusBar = "Comparing cells " & Format(c / maxC, "0 %") & "..."
For r = 1 To maxR
cf1 = "": cf2 = ""
On Error Resume Next
cf1 = ws1.Cells(r, c).FormulaLocal: cf2 = ws2.Cells(r, c).FormulaLocal
On Error GoTo 0
If cf1 <> cf2 Then
DiffCount = DiffCount + 1
Worksheets(2).Cells(r, c).Formula = " " & cf1 & " <> " & cf2
End If
Next r
Next c
Application.StatusBar = False
Debug.Print DiffCount & " So cell khac nhau ", vbInformation, "cua " & ws1.name & " with " & ws2.name
End Sub
OT muốn chuyển sang mảng nhưng loay hoay một hồi chưa biết cách, nhờ các bạn giúp đỡ ạ.
Xin chào các bạn,
Oanh Thơ (OT) đang sử dụng sub CompareWorksheets, với mục đích so sánh dữ liệu của 2 bảng tính tìm ra những ô khác nhau và ghi lại kết quả khác nhau ra một sheet khác:
Mã:
Public Sub CompareWorksheets(ws1 As Worksheet, ws2 As Worksheet)
Dim lr1 As Long, lr2 As Long, lc1 As Integer, lc2 As Integer
Dim maxR As Long, maxC As Integer, cf1 As String, cf2 As String
Dim DiffCount As Long, r As Long, c As Integer
lr1 = ws1.UsedRange.Rows.count: lc1 = ws1.UsedRange.Columns.count
lr2 = ws2.UsedRange.Rows.count: lc2 = ws2.UsedRange.Columns.count
maxR = lr1: maxC = lc1
If maxR < lr2 Then maxR = lr2: If maxC < lc2 Then maxC = lc2
DiffCount = 0
For c = 1 To maxC
Application.StatusBar = "Comparing cells " & Format(c / maxC, "0 %") & "..."
For r = 1 To maxR
cf1 = "": cf2 = ""
On Error Resume Next
cf1 = ws1.Cells(r, c).FormulaLocal: cf2 = ws2.Cells(r, c).FormulaLocal
On Error GoTo 0
If cf1 <> cf2 Then
DiffCount = DiffCount + 1
Worksheets(2).Cells(r, c).Formula = " " & cf1 & " <> " & cf2
End If
Next r
Next c
Application.StatusBar = False
Debug.Print DiffCount & " So cell khac nhau ", vbInformation, "cua " & ws1.name & " with " & ws2.name
End Sub
OT muốn chuyển sang mảng nhưng loay hoay một hồi chưa biết cách, nhờ các bạn giúp đỡ ạ.
Bài này có thể lấy 2 mảng dữ liệu rồi chạy 2 vòng For Next để so sánh. Không biết mình có hiểu sai hay không nhưng thấy cũng đơn giản mà. Bạn nhặt ở đâu cái đoạn code cao cấp quá vậy.
Chỉ cần so sánh
If sArr1(i,j) <> sArr2(i,j) Then
KQ(i,j)= "ABC"
End If
To tam888:
Chị này là vậy đó. Mấy anh chị mới học code thường vậy đó. Mình quen rồi nên nhìn là hiểu chị ấy muốn gì rồi
Bài này có thể lấy 2 mảng dữ liệu rồi chạy 2 vòng For Next để so sánh. Không biết mình có hiểu sai hay không nhưng thấy cũng đơn giản mà. Bạn nhặt ở đâu cái đoạn code cao cấp quá vậy.
Chỉ cần so sánh
If sArr1(i,j) <> sArr2(i,j) Then
KQ(i,j)= "ABC"
End If
To tam888:
Chị này là vậy đó. Mấy anh chị mới học code thường vậy đó. Mình quen rồi nên nhìn là hiểu chị ấy muốn gì rồi
Xin chào tam888, cảm ơn bạn đã quan tâm.
Dạ mục đích để minh họa cho thấy được sự thay đổi dữ liệu giữa 2sheet thôi ạ, nên dữ liệu là gì hay mẫu ra sao cũng không quan trọng ạ.
Bài này có thể lấy 2 mảng dữ liệu rồi chạy 2 vòng For Next để so sánh. Không biết mình có hiểu sai hay không nhưng thấy cũng đơn giản mà. Bạn nhặt ở đâu cái đoạn code cao cấp quá vậy.
Chỉ cần so sánh
If sArr1(i,j) <> sArr2(i,j) Then
KQ(i,j)= "ABC"
End If
To tam888:
Chị này là vậy đó. Mấy anh chị mới học code thường vậy đó. Mình quen rồi nên nhìn là hiểu chị ấy muốn gì rồi
Xin chào tam888, cảm ơn bạn đã quan tâm.
Dạ mục đích để minh họa cho thấy được sự thay đổi dữ liệu giữa 2sheet thôi ạ, nên dữ liệu là gì hay mẫu ra sao cũng không quan trọng ạ.
.
Xem lại bài #1,081 trên
Gặp dữ liệu kiểu này mọi người nản thường bỏ qua
Vì học mà giả lập dữ liệu ẩu, thì test sẽ ẩu thôi, đôi khi tưởng đúng mà không đúng
Ví dụ dữ liệu toàn cell có giá trị giống nhau vậy (chứa "data") thì thuật toán đơn giản hơn nhiều so với các ô (cells) có giá trị ngẫu nhiên khác nhau --> vậy khi xem file giả lập đại thế người ta sẽ định dữ liệu thế nào mà lượng ra thuật toán đây???, theo cái giống hệt nhau thế thì lúc thật lại sai
Chưa kể chính bạn test cũng dễ sai
Xem lại bài #1,081 trên
Gặp dữ liệu kiểu này mọi người nản thường bỏ qua
Vì học mà giả lập dữ liệu ẩu, thì test sẽ ẩu thôi, đôi khi tưởng đúng mà không đúng
Ví dụ dữ liệu toàn cell có giá trị giống nhau vậy (chứa "data") thì thuật toán đơn giản hơn nhiều so với các ô (cells) có giá trị ngẫu nhiên khác nhau
Public Sub SoSanh()
Dim Arr1(), Arr2(), Arr3()
Dim I As Long, J As Long, R As Long, Col As Long
Arr1 = Sheet1.Range("A1:N51").Value
Arr2 = Sheet2.Range("A1:N51").Value
R = UBound(Arr1): Col = UBound(Arr1, 2)
ReDim Arr3(1 To R, 1 To Col)
For I = 1 To R
For J = 1 To Col
If Arr1(I, J) <> Arr2(I, J) Then Arr3(I, J) = Arr1(I, J) & "<>" & Arr2(I, J)
Next J
Next I
Sheet3.Range("A1").Resize(R, Col) = Arr3
End Sub
Public Sub SoSanh()
Dim Arr1(), Arr2(), Arr3()
Dim I As Long, J As Long, R As Long, Col As Long
Arr1 = Sheet1.Range("A1:N51").Value
Arr2 = Sheet2.Range("A1:N51").Value
R = UBound(Arr1): Col = UBound(Arr1, 2)
ReDim Arr3(1 To R, 1 To Col)
For I = 1 To R
For J = 1 To Col
If Arr1(I, J) <> Arr2(I, J) Then Arr3(I, J) = Arr1(I, J) & "<>" & Arr2(I, J)
Next J
Next I
Sheet3.Range("A1").Resize(R, Col) = Arr3
End Sub
Lợi hại quá thầy ơi, con cảm ơn thầy nhiều ạ.
Code trước không so sánh được định dạng (value và text), nhưng code của thầy có thể phân biệt so sánh được.
Thật đơn giản mà hiệu quả,chắc chắn anh Quang Hải sẽ viết giống thầy rồi.Con nhớ ở bài viết nào đó anh Quanh Hải đã từng bị hỏi không kịp trở tay nên đã đọc thần chú "anh Ba Tê ơiii" ạ
Cảm ơn befaint,OT thử thí nghiệm:
gõ số 1 vào một ô ví dụ G7 trong sheet1 với định dạng qua Format Cells là "General"
và gõ số 1 vào một ô G7 trong sheet2 với định dạng qua Format Cells là "@"
Kết quả code ở bài #1078 , không nhận đạng được sự khác nhau.
Nhưng code ở bài #1085 của thầy BaTê thì nhận dạng được sự khác nhau này ạ.
OT cũng thử kiểm tra theo gợi ý của befaint:
Range.Value thì nhất định là Value (và chưa chắc là Text - nội dung hiển thị đã qua Format Cells)
Sub test()
If Sheet1.Range("G7").Value = Sheet2.Range("G7").Value Then
Sheet3.Range("G7").Value = True
Else
Sheet3.Range("G7").Value = False
End If
End Sub
OT đang hiểu value là số (có thể tính toán được) còn text là dạng chuỗi (không thể tính toán được).
Hiểu như vậy có phải vậy có sai lầm không vậy befaint? Nếu không phiền nhờ bạn giải thích giúp OT thêm một chút nữa ạ.
Cảm ơn befaint.
OT đang hiểu value là số (có thể tính toán được) còn text là dạng chuỗi (không thể tính toán được).
Hiểu như vậy có phải vậy có sai lầm không vậy befaint? Nếu không phiền nhờ bạn giải thích giúp OT thêm một chút nữa ạ.
Mình không bàn luận các bài giải trên, mà chỉ trích dẫn một phần bài của bạn và nêu lý thuyết.
Tức là, bạn đã nêu "Code trước không so sánh được định dạng (value và text), nhưng code của thầy có thể phân biệt so sánh được."
Rồi mình xem code ở bài trên có
Mã:
Arr1=Range.Value
Arr2=Range.Value
đều gọi tới thuộc tính Value của Range, chứ không hề xét thuộc tính Text của Range nên mình nêu lý thuyết để bạn phân biệt được:
- Định dạng (tức là có Format Cells).
- Value
- Text
---------
"value là số (có thể tính toán được) "
Value là Value (dịch ra là giá trị), có thể là number, có thể là string. Number thì mới có thể tính toán +-*/, string thì không tính toán +-*/ được.
Giờ xét một Cell. Nội dung ta nhìn thấy trên Cell (ở bảng tính) có thể:
- nhập từ bàn phím, hay được sao chép ở nguồn khác vào;
- kết quả của công thức nào đó trong Cell đó;
- định dạng đối với Cell đó.
Rồi ta xét hai thuộc tính .Value và .Text của một Cell kia xem chúng khác nhau thế nào (xem ví dụ ở 3.1 đã dẫn ở bài trước).
=> Túm lại để bạn nắm được lý thuyết và gọi tên đúng thôi (chỗ chữ màu đỏ).
Mình không bàn luận các bài giải trên, mà chỉ trích dẫn một phần bài của bạn và nêu lý thuyết.
Tức là, bạn đã nêu "Code trước không so sánh được định dạng (value và text), nhưng code của thầy có thể phân biệt so sánh được."
Rồi mình xem code ở bài trên có
Mã:
Arr1=Range.Value
Arr2=Range.Value
đều gọi tới thuộc tính Value của Range, chứ không hề xét thuộc tính Text của Range nên mình nêu lý thuyết để bạn phân biệt được:
- Định dạng (tức là có Format Cells).
- Value
- Text
---------
"value là số (có thể tính toán được) "
Value là Value (dịch ra là giá trị), có thể là number, có thể là string. Number thì mới có thể tính toán +-*/, string thì không tính toán +-*/ được.
Giờ xét một Cell. Nội dung ta nhìn thấy trên Cell (ở bảng tính) có thể:
- nhập từ bàn phím, hay được sao chép ở nguồn khác vào;
- kết quả của công thức nào đó trong Cell đó;
- định dạng đối với Cell đó.
Rồi ta xét hai thuộc tính .Value và .Text của một Cell kia xem chúng khác nhau thế nào (xem ví dụ ở 3.1 đã dẫn ở bài trước).
=> Túm lại để bạn nắm được lý thuyết và gọi tên đúng thôi (chỗ chữ màu đỏ).
Cảm ơn befaint rất nhiều, OT đã hiểu ạ.
Sau một thời gian bọn trẻ thi học kỳ I. OT không nghĩ gì đến code, giờ lại bắt đầu thấy mông lung.Thi thoảng OT vẫn tìm đến các bài viết về vba của bạn để đọc. Hic mỗi lần tìm cũng hơi mất chút thời gian, sao không thấy BQT không ghim lại các bài viết tổng hợp của bạn lại để mọi người có thể tiện xem nhỉ.
Cũng may GPE còn có rất nhiều người sẵn sàng có thể chỉ dẫn tận tình như bạn.
Chúc bạn một mùa đông ấm áp.
Lợi hại quá thầy ơi, con cảm ơn thầy nhiều ạ.
Code trước không so sánh được định dạng (value và text), nhưng code của thầy có thể phân biệt so sánh được.
Code của Ba Tê trả về TRUE, tức 2 ô bạn cho là giống nhau? 1 (số) <> 1 (text) thì cho là 2 ô khác nhau mà trong trường hợp này 2 ô lại như nhau? Vì bản chất 2 ô khác nhau rất nhiều. Một ô chứa hằng sồ, còn ô kia giá trị có thể thay đổi. Sau một nháy mắt sheet2!A3 có thể <> 2 do người dùng thay đổi A3, hoặc vd. A3 chứa công thức tham chiếu tới vd. C2 và người dùng thay đổi C2. Lúc này cả 2 A1 không còn giống nhau mặc dù ta không thay đổi trực tiếp 2 A1.
Có lẽ chính vì để phát hiện trường hợp này mà người ta dùng FormulaLocal thay cho Value?
Nếu bạn muốn người ta làm chính xác với mong đợi của mình thì bạn phải định nghĩa khái niệm "giống nhau" hoặc "khác nhau". Trừ phi bạn chưa nghĩ thấu đáo, khi nào thì coi là như nhau và khi nào thì coi là khác nhau.
Code của Ba Tê trả về TRUE, tức 2 ô bạn cho là giống nhau? 1 (số) <> 1 (text) thì cho là 2 ô khác nhau mà trong trường hợp này 2 ô lại như nhau? Vì bản chất 2 ô khác nhau rất nhiều. Một ô chứa hằng sồ, còn ô kia giá trị có thể thay đổi. Sau một nháy mắt sheet2!A3 có thể <> 2 do người dùng thay đổi A3, hoặc vd. A3 chứa công thức tham chiếu tới vd. C2 và người dùng thay đổi C2. Lúc này cả 2 A1 không còn giống nhau mặc dù ta không thay đổi trực tiếp 2 A1.
Có lẽ chính vì để phát hiện trường hợp này mà người ta dùng FormulaLocal thay cho Value?
Nếu bạn muốn người ta làm chính xác với mong đợi của mình thì bạn phải định nghĩa khái niệm "giống nhau" hoặc "khác nhau". Trừ phi bạn chưa nghĩ thấu đáo, khi nào thì coi là như nhau và khi nào thì coi là khác nhau.
Con chào bác Siwtom,
Dạ vâng, đúng là ngay từ đầu khi đưa code lên con chỉ nghĩ đến việc chuyển code đó sang mảng sẽ nhanh hơn,mà không nghĩ đến việc code đó phân tích cụ thể về các trường hợp khác nhau như thế nào, sau khi được thầy Ba Tê giúp đỡ con mới thử tò mò so sánh kiểm tra các trường hợp, đúng là con chưa thử trường hợp này:
Bây giờ ta xét trường hợp:
- sheet1: A1 = 5
- sheet2: A1 =SUM(A2:A3), A2 = 3, A3 = 2
Code của Ba Tê trả về TRUE, tức 2 ô bạn cho là giống nhau? 1 (số) <> 1 (text) thì cho là 2 ô khác nhau mà trong trường hợp này 2 ô lại như nhau? Vì bản chất 2 ô khác nhau rất nhiều. Một ô chứa hằng sồ, còn ô kia giá trị có thể thay đổi.
Sau khi con thử nghiệm thấy đúng thế ạ,híc cách nào cũng có ưu điểm và nhược điểm,tùy thuộc vào kiểu dữ liệu để áp dụng dùng trường hợp nào,nếu dữ liệu không có công thức thì dùng theo cách của thầy Ba Tê đưa hết vào mảng để so sánh, dùng mảng tốc độ sẽ nhanh phân biệt được text và number, còn với code con đưa lên sử dụng FormulaLocal so sánh được ô chứa công thức nhưng cũng không so sánh được với ô có Format Cells khác nhau (như ví dụ con đã đưa)...
Và con vừa mới tham khảo thêm ở đây để hiểu thêm nhưng dường như chủ đề cũng chưa đi đến kết quả cuối cùng: https://www.giaiphapexcel.com/diendan/threads/so-sánh-2-range-giúp-mình-với.1716/
Có lẽ chính vì để phát hiện trường hợp này mà người ta dùng FormulaLocal thay cho Value?
Trước đó khi được bạn @befaint hỗ trợ phân tích,con cũng định hỏi bạn ấy về thuộc tính FormulaLocal nhưng con nghĩ có lẽ con sẽ không dùng đến nên con đã không hỏi.
Cảm ơn HeSanbi,
Công việc của OT nếu không có sự trợ giúp của GPE thì không biết đến giờ sẽ kinh khủng như thế nào ạ.
Học VBA thì mới có thời gian để nội trợ ạ (không phải ôm việc về nhà làm)
Cháu cảm ơn chú Mỹ đã nói đỡ, đúng là do cháu suy nghĩ chưa thấu đáo. Cháu cũng đọc nhiều bài viết về vba và các tài liệu của chú, nhưng hình như đã lâu rồi chú không viết bài ạ?
Cháu cảm ơn chú Mỹ đã nói đỡ, đúng là do cháu suy nghĩ chưa thấu đáo. Cháu cũng đọc nhiều bài viết về vba và các tài liệu của chú, nhưng hình như đã lâu rồi chú không viết bài ạ?
Độ rày tôi cũng bận rộn quá, nhưng vẫn theo dõi diễn đàn và biết rằng GPE bây giờ nhiều người giỏi (nhiều hơn xưa) (befaint chẳng hạn).
Nói nhỏ:
Trừ con ếch xanh, code ào ào mà lý luận không đủ cơ sở, tính logic không đủ, căn bản không đạt
Bác Sa_DQ thì code vững nhưng ít giải thích và phân tích
TB:
- Mà bạn đọc bài số 1089 của befaint rồi mà vẫn còn nói "text và value" và "định dạng" theo cách của bạn?
- Topic nào của befaint mà bạn muốn "dán lên", cho tôi cái link tôi làm ngay.
Độ rày tôi cũng bận rộn quá, nhưng vẫn theo dõi diễn đàn và biết rằng GPE bây giờ nhiều người giỏi (nhiều hơn xưa) (befaint chẳng hạn).
Nói nhỏ:
Trừ con ếch xanh, code ào ào mà lý luận không đủ cơ sở, tính logic không đủ, căn bản không đạt
Bác Sa_DQ thì code vững nhưng ít giải thích và phân tích
TB:
- Mà bạn đọc bài số 1089 của befaint rồi mà vẫn còn nói "text và value" và "định dạng" theo cách của bạn?
- Topic nào của befaint mà bạn muốn "dán lên", cho tôi cái link tôi làm ngay.
Nhắc nhở cho cái cô bé kia kẻo lỡ cơ hội.
Vấn đề mảng nói chung, và mảng nhiều chiều nói riêng, ở đây KHÔNG CÓ ai giỏi bằng bác ấy. Lời nhận định này không có ngoại lệ, tức là kể cả tôi cũng nhường bác ấy.
Cô bé phải nhân cơ hội này mà hỏi bác ấy cách duyệt mảng 2 chiều. Và nhờ bác ấy giải thích.
Chú: đối với tôi thì viết code rõ, dễ đọc mới là tối ưu. Nhưng đối với các bạn, tốc độ mới quan trọng. Duyệt mảng có cách tốc độ ưu việt hơn cách khác khi ta hiểu rõ cấu trúc của nó.
Dạ, cháu cảm ơn chú Mỹ đã chỉ dẫn để cháu hiểu thêm về bản chất các thuộc tính của range ạ.
Cháu cảm ơn bác VetMini đã chỉ đường ạ, cháu cũng thường hỏi bác ấy nhiều,nhưng đầu óc cháu hay quên và tư duy kém linh hoạt nên mới hay hỏi ạ...vâng, khi có cơ hội cháu sẽ cố gắng hỏi bác ấy nhiều hơn nữa ạ.
Thực sự vấn đề này cháu chưa biết và hình dung được bác ạ:
... phải nhân cơ hội này mà hỏi bác ấy cách duyệt mảng 2 chiều.Và nhờ bác ấy giải thích...
Code của Ba Tê trả về TRUE, tức 2 ô bạn cho là giống nhau? 1 (số) <> 1 (text) thì cho là 2 ô khác nhau mà trong trường hợp này 2 ô lại như nhau? Vì bản chất 2 ô khác nhau rất nhiều. Một ô chứa hằng sồ, còn ô kia giá trị có thể thay đổi. Sau một nháy mắt sheet2!A3 có thể <> 2 do người dùng thay đổi A3, hoặc vd. A3 chứa công thức tham chiếu tới vd. C2 và người dùng thay đổi C2. Lúc này cả 2 A1 không còn giống nhau mặc dù ta không thay đổi trực tiếp 2 A1.
Có lẽ chính vì để phát hiện trường hợp này mà người ta dùng FormulaLocal thay cho Value?
Nếu bạn muốn người ta làm chính xác với mong đợi của mình thì bạn phải định nghĩa khái niệm "giống nhau" hoặc "khác nhau". Trừ phi bạn chưa nghĩ thấu đáo, khi nào thì coi là như nhau và khi nào thì coi là khác nhau.
Có gì mà lạ bác, mọi người toàn vội vàng sống gấp, suy nghĩ nhanh, code cũng muốn code nhanh dù chẳng hơn nhau mấy % giây (tức là hiệu quả gần như bằng 0)
File dữ liệu người hỏi thì ẩu từ cách làm file data - thì kết quả sẽ đa dạng thôi.
Có gì mà lạ bác, mọi người toàn vội vàng sống gấp, suy nghĩ nhanh, code cũng muốn code nhanh dù chẳng hơn nhau mấy % giây (tức là hiệu quả gần như bằng 0)
...
Tôi không tin lắm.
Theo tôi thì chỉ vì một vài vị có máu mặt trong diễn đàn này chú trọng "tốc độ chạy của code" cho nên những người học code theo họ cứ nghĩ rằng đấy là chân lý của lập trình ứng dụng.
Đọc bài quen ở đây sẽ thấy "trường phái GPE" sắp hạng những điều được coi là "tối ưu code":
1. tốc độ chạy
2. số dòng code
3. số vòng lặp
Xin chào các bạn,
Oanh Thơ đang sử dụng hàm "RemoveDupesDict" để xóa các các dữ liệu trùng:
Mã:
Function RemoveDupesDict(MyArray As Variant) As Variant
' SOURCE: https://wellsr.com
Dim i As Long, Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
With Dic
For i = LBound(MyArray) To UBound(MyArray)
If IsMissing(MyArray(i)) = False Then
.Item(MyArray(i)) = 1
End If
Next
RemoveDupesDict = .Keys
End With
End Function
Và 1 sub Test_RemoveDupesDict
Mã:
Sub Test_RemoveDupesDict()
Dim arr1() As Variant, arr2() As Variant
Dim sh As Worksheet: Set sh = ThisWorkbook.Worksheets("Sheet1")
arr1 = sh.Range("A1:R1").Value
arr2 = RemoveDupesDict(Application.Transpose(Application.Transpose(arr1)))
sh.Range("A2").Resize(, UBound(arr2)) = arr2
arr1 = sh.Range("A4:A20").Value
arr2 = RemoveDupesDict(Application.Transpose(arr1))
sh.Range("B4").Resize(UBound(arr2)) = arr2
End Sub
Nhờ các bạn sửa giúp hàm "RemoveDupesDict" để không phải sử dụng đến các hàm hỗ trợ "Application.Transpose", kết quả mong muốn hàm sau khi sửa sẽ viết như sau:
Mã:
Sub Test_RemoveDupesDict()
Dim arr1() As Variant, arr2() As Variant
Dim sh As Worksheet: Set sh = ThisWorkbook.Worksheets("Sheet1")
arr1 = sh.Range("A1:R1").Value
arr2 = RemoveDupesDict(arr1)
sh.Range("A2").Resize(, UBound(arr2)) = arr2
arr1 = sh.Range("A4:A20").Value
arr2 = RemoveDupesDict(arr1)
sh.Range("B4").Resize(UBound(arr2)+1) = arr2
arr1 = sh.Range("D6:E22").Value
arr2 = RemoveDupesDict(arr1)
sh.Range("I6").Resize(UBound(arr2)+1, 2) = arr2
End Sub
Xin chào các bạn,
Oanh Thơ đang sử dụng hàm "RemoveDupesDict" để xóa các các dữ liệu trùng:
Mã:
Function RemoveDupesDict(MyArray As Variant) As Variant
' SOURCE: https://wellsr.com
Dim i As Long, Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
With Dic
For i = LBound(MyArray) To UBound(MyArray)
If IsMissing(MyArray(i)) = False Then
.Item(MyArray(i)) = 1
End If
Next
RemoveDupesDict = .Keys
End With
End Function
Và 1 sub Test_RemoveDupesDict
Mã:
Sub Test_RemoveDupesDict()
Dim arr1() As Variant, arr2() As Variant
Dim sh As Worksheet: Set sh = ThisWorkbook.Worksheets("Sheet1")
arr1 = sh.Range("A1:R1").Value
arr2 = RemoveDupesDict(Application.Transpose(Application.Transpose(arr1)))
sh.Range("A2").Resize(, UBound(arr2)) = arr2
arr1 = sh.Range("A4:A20").Value
arr2 = RemoveDupesDict(Application.Transpose(arr1))
sh.Range("B4").Resize(UBound(arr2)) = arr2
End Sub
Nhờ các bạn sửa giúp hàm "RemoveDupesDict" để không phải sử dụng đến các hàm hỗ trợ "Application.Transpose", kết quả mong muốn hàm sau khi sửa sẽ viết như sau:
Mã:
Sub Test_RemoveDupesDict()
Dim arr1() As Variant, arr2() As Variant
Dim sh As Worksheet: Set sh = ThisWorkbook.Worksheets("Sheet1")
arr1 = sh.Range("A1:R1").Value
arr2 = RemoveDupesDict(arr1)
sh.Range("A2").Resize(, UBound(arr2)) = arr2
arr1 = sh.Range("A4:A20").Value
arr2 = RemoveDupesDict(arr1)
sh.Range("B4").Resize(UBound(arr2)+1) = arr2
arr1 = sh.Range("D6:E22").Value
arr2 = RemoveDupesDict(arr1)
sh.Range("I6").Resize(UBound(arr2)+1, 2) = arr2
End Sub
Sub Test_RemoveDupesDict()
Dim arr1() As Variant, arr2() As Variant
Dim sh As Worksheet: Set sh = ThisWorkbook.Worksheets("Sheet1")
arr1 = sh.Range("d6:e22").Value
arr2 = RemoveDupesDict(arr1, 1)
sh.Range("i6").Resize(UBound(arr2, 1), UBound(arr2, 2)) = arr2
End Sub
Function RemoveDupesDict(MyArray As Variant, Optional ByVal so = 1) As Variant
Dim arr, a As Integer, j As Long
ReDim arr(1 To UBound(MyArray, 1), 1 To UBound(MyArray, 2))
' SOURCE: https://wellsr.com
Dim i As Long, Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
With Dic
For i = LBound(MyArray, 1) To UBound(MyArray, 1)
If Not .exists(MyArray(i, so)) Then
a = a + 1
For j = 1 To UBound(MyArray, 2)
arr(a, j) = MyArray(i, j)
Next j
.Item(MyArray(i, so)) = 1
End If
Next
RemoveDupesDict = arr
End With
End Function
Sub Test_RemoveDupesDict()
Dim arr1() As Variant, arr2() As Variant
Dim sh As Worksheet: Set sh = ThisWorkbook.Worksheets("Sheet1")
arr1 = sh.Range("d6:e22").Value
arr2 = RemoveDupesDict(arr1, 1)
sh.Range("i6").Resize(UBound(arr2, 1), UBound(arr2, 2)) = arr2
End Sub
Function RemoveDupesDict(MyArray As Variant, Optional ByVal so = 1) As Variant
Dim arr, a As Integer, j As Long
ReDim arr(1 To UBound(MyArray, 1), 1 To UBound(MyArray, 2))
' SOURCE: https://wellsr.com
Dim i As Long, Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
With Dic
For i = LBound(MyArray, 1) To UBound(MyArray, 1)
If Not .exists(MyArray(i, so)) Then
a = a + 1
For j = 1 To UBound(MyArray, 2)
arr(a, j) = MyArray(i, j)
Next j
.Item(MyArray(i, so)) = 1
End If
Next
RemoveDupesDict = arr
End With
End Function
Xin chào snow25
Cảm ơn bạn nhiều,OT test thử 3 trường hợp như sau:
Mã:
Sub Test_RemoveDupesDict()
Dim arr1() As Variant, arr2() As Variant
Dim sh As Worksheet: Set sh = ThisWorkbook.Worksheets("Sheet1")
'1:
arr1 = sh.Range("A1:Q1").Value
arr2 = RemoveDupesDict(arr1)
sh.Range("A2").Resize(, UBound(arr2)) = arr2 'chỉ trả về được 1 phần tử trong arr2
'2:
arr1 = sh.Range("A4:A20").Value
arr2 = RemoveDupesDict(arr1)
sh.Range("B4").Resize(UBound(arr2)) = arr2
'3:
arr1 = sh.Range("d6:e22").Value
arr2 = RemoveDupesDict(arr1, 1)
sh.Range("i6").Resize(UBound(arr2, 1), UBound(arr2, 2)) = arr2
End Sub
2, trường hợp thì OK, còn đầu tiên trường hợp:
Mã:
arr1 = sh.Range("A1:Q1").Value
arr2 = RemoveDupesDict(arr1)
sh.Range("A2").Resize(, UBound(arr2)) = arr2 'chỉ trả về được 1 phần tử trong arr2
Xin chào snow25
Cảm ơn bạn nhiều,OT test thử 3 trường hợp như sau:
Mã:
Sub Test_RemoveDupesDict()
Dim arr1() As Variant, arr2() As Variant
Dim sh As Worksheet: Set sh = ThisWorkbook.Worksheets("Sheet1")
'1:
arr1 = sh.Range("A1:Q1").Value
arr2 = RemoveDupesDict(arr1)
sh.Range("A2").Resize(, UBound(arr2)) = arr2 'chỉ trả về được 1 phần tử trong arr2
'2:
arr1 = sh.Range("A4:A20").Value
arr2 = RemoveDupesDict(arr1)
sh.Range("B4").Resize(UBound(arr2)) = arr2
'3:
arr1 = sh.Range("d6:e22").Value
arr2 = RemoveDupesDict(arr1, 1)
sh.Range("i6").Resize(UBound(arr2, 1), UBound(arr2, 2)) = arr2
End Sub
2, trường hợp thì OK, còn đầu tiên trường hợp:
Mã:
arr1 = sh.Range("A1:Q1").Value
arr2 = RemoveDupesDict(arr1)
sh.Range("A2").Resize(, UBound(arr2)) = arr2 'chỉ trả về được 1 phần tử trong arr2
Cái hàm
Function RemoveDupesDict(MyArray As Variant, Optional ByVal so = 1) As Variant và If Not .exists(MyArray(i, so)) Then vì vậy arr1 = sh.Range("A1:Q1").Value thì sh.Range("A2").Resize(, UBound(arr2)) = arr2 trả về kết quả là A1 là đúng rồi
Đáng nhẽ phải là UBound(arr2,2) chứ
Cái hàm
Function RemoveDupesDict(MyArray As Variant, Optional ByVal so = 1) As Variant và If Not .exists(MyArray(i, so)) Then vì vậy arr1 = sh.Range("A1:Q1").Value thì trả về kết quả là A1 là đúng rồi
Xin chào snow25
Cảm ơn bạn nhiều,OT test thử 3 trường hợp như sau:
Mã:
Sub Test_RemoveDupesDict()
Dim arr1() As Variant, arr2() As Variant
Dim sh As Worksheet: Set sh = ThisWorkbook.Worksheets("Sheet1")
'1:
arr1 = sh.Range("A1:Q1").Value
arr2 = RemoveDupesDict(arr1)
sh.Range("A2").Resize(, UBound(arr2)) = arr2 'chỉ trả về được 1 phần tử trong arr2
'2:
arr1 = sh.Range("A4:A20").Value
arr2 = RemoveDupesDict(arr1)
sh.Range("B4").Resize(UBound(arr2)) = arr2
'3:
arr1 = sh.Range("d6:e22").Value
arr2 = RemoveDupesDict(arr1, 1)
sh.Range("i6").Resize(UBound(arr2, 1), UBound(arr2, 2)) = arr2
End Sub
2, trường hợp thì OK, còn đầu tiên trường hợp:
Mã:
arr1 = sh.Range("A1:Q1").Value
arr2 = RemoveDupesDict(arr1)
sh.Range("A2").Resize(, UBound(arr2)) = arr2 'chỉ trả về được 1 phần tử trong arr2
Sub Test_RemoveDupesDict()
Dim arr1() As Variant, arr2() As Variant
Dim sh As Worksheet: Set sh = ThisWorkbook.Worksheets("Sheet1")
arr1 = sh.Range("a1:q1").Value
arr2 = RemoveDupesDict(arr1, 1, 2)
sh.Range("i6").Resize(UBound(arr2, 1), UBound(arr2, 2)) = arr2
End Sub
Function RemoveDupesDict(MyArray As Variant, Optional ByVal so = 1, Optional ByVal dk = 1) As Variant
Dim arr, a As Integer, j As Long
' SOURCE: https://wellsr.com
Dim i As Long, Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
With Dic
Select Case dk
Case 1
ReDim arr(1 To UBound(MyArray, 1), 1 To UBound(MyArray, 2))
For i = LBound(MyArray, 1) To UBound(MyArray, 1)
If Not .exists(MyArray(i, so)) Then
a = a + 1
For j = 1 To UBound(MyArray, 2)
arr(a, j) = MyArray(i, j)
Next j
.Item(MyArray(i, so)) = 1
End If
Next
Case 2
ReDim arr(1 To UBound(MyArray, 2), 1 To UBound(MyArray, 1))
For i = LBound(MyArray, 2) To UBound(MyArray, 2)
If Not .exists(MyArray(1, i)) Then
a = a + 1
arr(a, 1) = MyArray(1, i)
.Item(MyArray(1, i)) = 1
End If
Next
End Select
RemoveDupesDict = arr
End With
End Function
Sub Test_RemoveDupesDict()
Dim arr1() As Variant, arr2() As Variant
Dim sh As Worksheet: Set sh = ThisWorkbook.Worksheets("Sheet1")
arr1 = sh.Range("a1:q1").Value
arr2 = RemoveDupesDict(arr1, 1, 2)
sh.Range("i6").Resize(UBound(arr2, 1), UBound(arr2, 2)) = arr2
End Sub
Function RemoveDupesDict(MyArray As Variant, Optional ByVal so = 1, Optional ByVal dk = 1) As Variant
Dim arr, a As Integer, j As Long
' SOURCE: https://wellsr.com
Dim i As Long, Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
With Dic
Select Case dk
Case 1
ReDim arr(1 To UBound(MyArray, 1), 1 To UBound(MyArray, 2))
For i = LBound(MyArray, 1) To UBound(MyArray, 1)
If Not .exists(MyArray(i, so)) Then
a = a + 1
For j = 1 To UBound(MyArray, 2)
arr(a, j) = MyArray(i, j)
Next j
.Item(MyArray(i, so)) = 1
End If
Next
Case 2
ReDim arr(1 To UBound(MyArray, 2), 1 To UBound(MyArray, 1))
For i = LBound(MyArray, 2) To UBound(MyArray, 2)
If Not .exists(MyArray(1, i)) Then
a = a + 1
arr(a, 1) = MyArray(1, i)
.Item(MyArray(1, i)) = 1
End If
Next
End Select
RemoveDupesDict = arr
End With
End Function
Cảm ơn snow25 nhiều ạ,
Bạn có thể sửa giúp OT trong trường hợp, nếu dk=2 khi muốn đưa các phần tử trong mảng vào 1 dòng , thì không phải sử dụng "Application.Transpose" nữa được không ạ:
Cảm ơn snow25 nhiều ạ,
Bạn có thể sửa giúp OT trong trường hợp, nếu dk=2 khi muốn đưa các phần tử trong mảng vào 1 dòng , thì không phải sử dụng "Application.Transpose" nữa được không ạ:
Hihi, loay hoay một lúc với cái Case 2 hình như OK rồi. Xin cảm ơn snow25 nhiều ạ.
OT gửi lại code, nếu có chỗ nào chưa tối ưu (có thể phát sinh lỗi) nhờ các bạn góp ý thêm ạ:
Mã:
Option Explicit
Sub Test_RemoveDupesDict_2()
Dim arr1() As Variant, arr2() As Variant
Dim sh As Worksheet: Set sh = ThisWorkbook.Worksheets("Sheet1")
'1:
arr1 = sh.Range("A1:Q1").Value
arr2 = RemoveDupesDict_2(arr1, 1, 2)
sh.Range("A2").Resize(, UBound(arr2)) = arr2
'2:
arr1 = sh.Range("A4:A20").Value
arr2 = RemoveDupesDict_2(arr1)
sh.Range("B4").Resize(UBound(arr2)) = arr2
'3:
arr1 = sh.Range("D6:E22").Value
arr2 = RemoveDupesDict_2(arr1, 1)
sh.Range("I6").Resize(UBound(arr2, 1), UBound(arr2, 2)) = arr2
End Sub
Function RemoveDupesDict_2(MyArray As Variant, Optional ByVal so = 1, Optional ByVal dk = 1) As Variant
Dim arr, a As Integer, j As Long
' SOURCE: https://wellsr.com
Dim i As Long, Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
With Dic
Select Case dk
Case 1
ReDim arr(1 To UBound(MyArray, 1), 1 To UBound(MyArray, 2))
For i = LBound(MyArray, 1) To UBound(MyArray, 1)
If Not .exists(MyArray(i, so)) Then
a = a + 1
For j = 1 To UBound(MyArray, 2)
arr(a, j) = MyArray(i, j)
Next j
.Item(MyArray(i, so)) = 1
End If
Next i
Case 2
ReDim arr(1 To UBound(MyArray, 2))
For i = LBound(MyArray, 2) To UBound(MyArray, 2)
If Not .exists(MyArray(1, i)) Then
a = a + 1
arr(a) = MyArray(1, i)
.Item(MyArray(1, i)) = 1
End If
Next i
End Select
RemoveDupesDict_2 = arr
End With
End Function