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ị
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