Sửa giúp code dồn số liệu (1 người xem)

Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
Sắp xếp theo thời gian sắp xếp theo bầu chọn
hiénlinh197 đã viết:
Nhờ các bạn sửa giúp code theo file đính kèm,
Cảm ơn các bạn!
Nhấp chuột vào đây để mở rộng...
Thử code
Mã: 
Sub Rectangle1_Click()
    Dim Arr(), kq(), i As Long, j As Long, k As Long, jMax As Long
    Arr = Sheet1.Range("l3:z22").Value
    ReDim kq(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
    For i = 1 To UBound(Arr, 1)
        k = 0
        For j = 1 To UBound(Arr, 2)
            If Arr(i, j) <> "" Then
                k = k + 1
                kq(i, k) = Arr(i, j)
            End If
        Next j
        If jMax < k Then jMax = k 'Tính só cot ket qua
    Next i
    Sheet1.Range("A3").Resize(UBound(kq, 1), jMax).Value = kq
End Sub
Nếu không đúng ý thì nhập kết quả và gởi lên
 
Upvote 0
HieuCD đã viết:
Thử code
Mã: 
Sub Rectangle1_Click()
    Dim Arr(), kq(), i As Long, j As Long, k As Long, jMax As Long
    Arr = Sheet1.Range("l3:z22").Value
    ReDim kq(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
    For i = 1 To UBound(Arr, 1)
        k = 0
        For j = 1 To UBound(Arr, 2)
            If Arr(i, j) <> "" Then
                k = k + 1
                kq(i, k) = Arr(i, j)
            End If
        Next j
        If jMax < k Then jMax = k 'Tính só cot ket qua
    Next i
    Sheet1.Range("A3").Resize(UBound(kq, 1), jMax).Value = kq
End Sub
Nếu không đúng ý thì nhập kết quả và gởi lên
Nhấp chuột vào đây để mở rộng...
Cảm ơn anh
HieuCD
. Anh ơi nhưng em muốn là các số trùng nhau thì chỉ lấy 1 số . anh sửa giúp em với nhé!
 
Upvote 0
hiénlinh197 đã viết:
Cảm ơn anh
HieuCD
. Anh ơi nhưng em muốn là các số trùng nhau thì chỉ lấy 1 số . anh sửa giúp em với nhé!
Nhấp chuột vào đây để mở rộng...
Mã: 
Sub Rectangle1_Click()
    Dim Arr(), kq(), i As Long, j As Long, k As Long, jMax As Long, key As String
    Arr = Sheet1.Range("l3:z22").Value
    ReDim kq(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
    With CreateObject("Scripting.dictionary")
        For i = 1 To UBound(Arr, 1)
            k = 0
            For j = 1 To UBound(Arr, 2)
                key = CStr(Arr(i, j))
                If key <> "" Then
                    If Not .exists(key) Then
                        .Add key, ""
                        k = k + 1
                        kq(i, k) = key
                    End If
                End If
            Next j
            .RemoveAll 'Neu loai trung tat ca dòng thì bo lenh nay
            If jMax < k Then jMax = k 'Tính só cot ket qua
        Next i
    End With
    Sheet1.Range("A3").Resize(UBound(kq, 1), jMax).Value = kq
End Sub
 
Upvote 0
HieuCD đã viết:
Mã: 
Sub Rectangle1_Click()
    Dim Arr(), kq(), i As Long, j As Long, k As Long, jMax As Long, key As String
    Arr = Sheet1.Range("l3:z22").Value
    ReDim kq(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
    With CreateObject("Scripting.dictionary")
        For i = 1 To UBound(Arr, 1)
            k = 0
            For j = 1 To UBound(Arr, 2)
                key = CStr(Arr(i, j))
                If key <> "" Then
                    If Not .exists(key) Then
                        .Add key, ""
                        k = k + 1
                        kq(i, k) = key
                    End If
                End If
            Next j
            .RemoveAll 'Neu loai trung tat ca dòng thì bo lenh nay
            If jMax < k Then jMax = k 'Tính só cot ket qua
        Next i
    End With
    Sheet1.Range("A3").Resize(UBound(kq, 1), jMax).Value = kq
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn anh rất nhiều, code chạy rất chuẩn anh à, Nhưng bây giờ anh giúp em chút síu nữa là khi muốn dồn 2 hoặc nhiều mảng không liền kề nhau thì làm như nào?
 

File đính kèm

Upvote 0
hiénlinh197 đã viết:
Cảm ơn anh rất nhiều, code chạy rất chuẩn anh à, Nhưng bây giờ anh giúp em chút síu nữa là khi muốn dồn 2 hoặc nhiều mảng không liền kề nhau thì làm như nào?
Nhấp chuột vào đây để mở rộng...
Thêm vòng lập tính dòng cuối mảng dữ liệu, bạn có thể nhìn bảng và nhập trực tiếp vào lệnh tạo mảng Arr
Mã: 
Sub donso() 'Hieucd b2
    Dim Arr(), kq(), i As Long, j As Long, k As Long, jMax As Long, key As String
    For j = 12 To 26 'Cot L toi cot Z
      i = Cells(65500, j).End(xlUp).Row 'dòng cuoi cot j
      If i > k Then k = i 'dòng cuoi cua mang du lieu
    Next j
    Arr = Sheet1.Range("L3:Z" & k).Value
    ReDim kq(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
    With CreateObject("Scripting.dictionary")
        For i = 1 To UBound(Arr, 1)
            k = 0
            For j = 1 To UBound(Arr, 2)
                key = CStr(Arr(i, j))
                If key <> "" Then
                    If Not .exists(key) Then
                        .Add key, ""
                        k = k + 1
                        kq(i, k) = key
                    End If
                End If
            Next j
            .RemoveAll 'Neu loai trung tat ca dòng thì bo lenh nay
            If jMax < k Then jMax = k 'Tính só cot ket qua
        Next i
    End With
    Sheet1.Range("A3").Resize(UBound(kq, 1), jMax).Value = kq
End Sub
 
Upvote 0
HieuCD đã viết:
Thêm vòng lập tính dòng cuối mảng dữ liệu, bạn có thể nhìn bảng và nhập trực tiếp vào lệnh tạo mảng Arr
Mã: 
Sub donso() 'Hieucd b2
    Dim Arr(), kq(), i As Long, j As Long, k As Long, jMax As Long, key As String
    For j = 12 To 26 'Cot L toi cot Z
      i = Cells(65500, j).End(xlUp).Row 'dòng cuoi cot j
      If i > k Then k = i 'dòng cuoi cua mang du lieu
    Next j
    Arr = Sheet1.Range("L3:Z" & k).Value
    ReDim kq(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
    With CreateObject("Scripting.dictionary")
        For i = 1 To UBound(Arr, 1)
            k = 0
            For j = 1 To UBound(Arr, 2)
                key = CStr(Arr(i, j))
                If key <> "" Then
                    If Not .exists(key) Then
                        .Add key, ""
                        k = k + 1
                        kq(i, k) = key
                    End If
                End If
            Next j
            .RemoveAll 'Neu loai trung tat ca dòng thì bo lenh nay
            If jMax < k Then jMax = k 'Tính só cot ket qua
        Next i
    End With
    Sheet1.Range("A3").Resize(UBound(kq, 1), jMax).Value = kq
End Sub
Nhấp chuột vào đây để mở rộng...
HieuCD đã viết:
Thêm vòng lập tính dòng cuối mảng dữ liệu, bạn có thể nhìn bảng và nhập trực tiếp vào lệnh tạo mảng Arr
Mã: 
Sub donso() 'Hieucd b2
    Dim Arr(), kq(), i As Long, j As Long, k As Long, jMax As Long, key As String
    For j = 12 To 26 'Cot L toi cot Z
      i = Cells(65500, j).End(xlUp).Row 'dòng cuoi cot j
      If i > k Then k = i 'dòng cuoi cua mang du lieu
    Next j
    Arr = Sheet1.Range("L3:Z" & k).Value
    ReDim kq(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
    With CreateObject("Scripting.dictionary")
        For i = 1 To UBound(Arr, 1)
            k = 0
            For j = 1 To UBound(Arr, 2)
                key = CStr(Arr(i, j))
                If key <> "" Then
                    If Not .exists(key) Then
                        .Add key, ""
                        k = k + 1
                        kq(i, k) = key
                    End If
                End If
            Next j
            .RemoveAll 'Neu loai trung tat ca dòng thì bo lenh nay
            If jMax < k Then jMax = k 'Tính só cot ket qua
        Next i
    End With
    Sheet1.Range("A3").Resize(UBound(kq, 1), jMax).Value = kq
End Sub
Nhấp chuột vào đây để mở rộng...
Em cảm ơn anh
HieuCD
, rất chuẩn anh à! Bây giờ em muốn dồn kết quả vào 1 dòng thì phải làm như nào hả anh? Em loay hoay mãi từ đêm qua tới bây giờ mà vẫn chưa sửa được. Anh sửa giúp em với. Cảm ơn anh rất nhiều.
 
Upvote 0
hiénlinh197 đã viết:
Em cảm ơn anh
HieuCD
, rất chuẩn anh à! Bây giờ em muốn dồn kết quả vào 1 dòng thì phải làm như nào hả anh? Em loay hoay mãi từ đêm qua tới bây giờ mà vẫn chưa sửa được. Anh sửa giúp em với. Cảm ơn anh rất nhiều.
Nhấp chuột vào đây để mở rộng...
Nhập tay kết quả gởi lên
 
Upvote 0
hiénlinh197 đã viết:
Dạ cảm ơn anh!
Nhấp chuột vào đây để mở rộng...
Mã: 
Sub donso() 'Hieucd b3 (Láy nhieu mang)
    Dim Arr(), kq(), i As Long, j As Long, k As Long, jMax As Long, key
    For j = 12 To 26 'Cot L toi cot Z
      i = Cells(65500, j).End(xlUp).Row 'dòng cuoi cot j
      If i > k Then k = i 'dòng cuoi cua mang du lieu
    Next j
    Arr = Sheet1.Range("L4:Z" & k).Value
    k = 0
    With CreateObject("Scripting.dictionary")
        For i = 1 To UBound(Arr, 1)
            For j = 1 To UBound(Arr, 2)
                key = Arr(i, j)
                If TypeName(key) = "Double" Then
                    If Not .exists(key) Then
                        .Add key, ""
                        k = k + 1
                        ReDim Preserve kq(1 To k)
                        kq(k) = key
                    End If
                End If
            Next j
        Next i
    End With
    Sheet1.Range("B2").Resize(, k).Value = kq
End Sub
 
Upvote 0
Thử rút gọn code của bạn HieuCD
Mã: 
Sub donso() 'Hieucd b3 (Láy nhieu mang)
Dim Arr(), i As Long, j As Long, k As Long, key
    For j = 12 To 26 'Cot L toi cot Z
        i = Sheet1.Cells(Rows.Count, j).End(xlUp).Row 'dong cuoi cot j
        If i > k Then k = i 'dong cuoi cua mang du lieu
    Next j
    Arr = Sheet1.Range("L4:Z" & k).Value
    With CreateObject("Scripting.dictionary")
        For i = 1 To UBound(Arr, 1)
            For j = 1 To UBound(Arr, 2)
                key = Arr(i, j)
                If TypeName(key) = "Double" Then
                    If Not .exists(key) Then .Add key, ""
                End If
            Next j
        Next i
        Sheet1.Range("B2").Resize(, .Count).Value = .keys()
    End With
End Sub
 
Upvote 0
HieuCD đã viết:
Mã: 
Sub donso() 'Hieucd b3 (Láy nhieu mang)
    Dim Arr(), kq(), i As Long, j As Long, k As Long, jMax As Long, key
    For j = 12 To 26 'Cot L toi cot Z
      i = Cells(65500, j).End(xlUp).Row 'dòng cuoi cot j
      If i > k Then k = i 'dòng cuoi cua mang du lieu
    Next j
    Arr = Sheet1.Range("L4:Z" & k).Value
    k = 0
    With CreateObject("Scripting.dictionary")
        For i = 1 To UBound(Arr, 1)
            For j = 1 To UBound(Arr, 2)
                key = Arr(i, j)
                If TypeName(key) = "Double" Then
                    If Not .exists(key) Then
                        .Add key, ""
                        k = k + 1
                        ReDim Preserve kq(1 To k)
                        kq(k) = key
                    End If
                End If
            Next j
        Next i
    End With
    Sheet1.Range("B2").Resize(, k).Value = kq
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn anh
HieuCD!
code rất tuyệt vời anh à! Chúc anh công tác tốt và gặp nhiều may mắn mọi điều an lành.
 
Upvote 0
batman1 đã viết:
Thử rút gọn code của bạn HieuCD
Mã: 
Sub donso() 'Hieucd b3 (Láy nhieu mang)
Dim Arr(), i As Long, j As Long, k As Long, key
    For j = 12 To 26 'Cot L toi cot Z
        i = Sheet1.Cells(Rows.Count, j).End(xlUp).Row 'dong cuoi cot j
        If i > k Then k = i 'dong cuoi cua mang du lieu
    Next j
    Arr = Sheet1.Range("L4:Z" & k).Value
    With CreateObject("Scripting.dictionary")
        For i = 1 To UBound(Arr, 1)
            For j = 1 To UBound(Arr, 2)
                key = Arr(i, j)
                If TypeName(key) = "Double" Then
                    If Not .exists(key) Then .Add key, ""
                End If
            Next j
        Next i
        Sheet1.Range("B2").Resize(, .Count).Value = .keys()
    End With
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn
batman1
đã rút gọn code, chạy rất tốt, nhưng có điều là không xóa dữ liệu cũ đi nên hay bị nhầm dữ liệu.
 
Upvote 0
Upvote 0
hiénlinh197 đã viết:
Nhờ các bạn sửa giúp code theo file đính kèm,
Cảm ơn các bạn!
Nhấp chuột vào đây để mở rộng...
Bài này trước đây tôi có làm 1 lần, nó thế này:
1> Viết 1 hàm lọc duy nhất
Mã: 
Function UniqueList(ParamArray Arrays())
  Dim item, aTmpArr, aSubArr
  'On Error Resume Next
  With CreateObject("Scripting.Dictionary")
    For Each aSubArr In Arrays
      aTmpArr = aSubArr
      If Not IsArray(aTmpArr) Then aTmpArr = Array(aTmpArr)
      For Each item In aTmpArr
        If TypeName(item) <> "Error" Then
          If Len(item) Then
            If Not .exists(item) Then .Add item, Empty
          End If
        End If
      Next
    Next
    If .Count Then UniqueList = .Keys
  End With
End Function
2> Code áp dụng:
Mã: 
Sub Main()
  Dim Arr
  Arr = UniqueList(Range("L4:Z23"), Range("L31:Z50"))
  If IsArray(Arr) Then Range("B2").Resize(, UBound(Arr) + 1).Value = Arr
End Sub
 
Upvote 0
ndu96081631 đã viết:
Bài này trước đây tôi có làm 1 lần, nó thế này:
1> Viết 1 hàm lọc duy nhất
Mã: 
Function UniqueList(ParamArray Arrays())
  Dim item, aTmpArr, aSubArr
  'On Error Resume Next
  With CreateObject("Scripting.Dictionary")
    For Each aSubArr In Arrays
      aTmpArr = aSubArr
      If Not IsArray(aTmpArr) Then aTmpArr = Array(aTmpArr)
      For Each item In aTmpArr
        If TypeName(item) <> "Error" Then
          If Len(item) Then
            If Not .exists(item) Then .Add item, Empty
          End If
        End If
      Next
    Next
    If .Count Then UniqueList = .Keys
  End With
End Function
2> Code áp dụng:
Mã: 
Sub Main()
  Dim Arr
  Arr = UniqueList(Range("L4:Z23"), Range("L31:Z50"))
  If IsArray(Arr) Then Range("B2").Resize(, UBound(Arr) + 1).Value = Arr
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn bác
ndu96081631
đã quan tâm vấn đề và giúp đỡ. Nhưng bác
ndu96081631
vẫn chưa xóa dữ liệu cũ đi bác à.
 
Upvote 0
ndu96081631 đã viết:
Bài này trước đây tôi có làm 1 lần, nó thế này:
1> Viết 1 hàm lọc duy nhất
Mã: 
Function UniqueList(ParamArray Arrays())
  Dim item, aTmpArr, aSubArr
  'On Error Resume Next
  With CreateObject("Scripting.Dictionary")
    For Each aSubArr In Arrays
      aTmpArr = aSubArr
      If Not IsArray(aTmpArr) Then aTmpArr = Array(aTmpArr)
      For Each item In aTmpArr
        If TypeName(item) <> "Error" Then
          If Len(item) Then
            If Not .exists(item) Then .Add item, Empty
          End If
        End If
      Next
    Next
    If .Count Then UniqueList = .Keys
  End With
End Function
2> Code áp dụng:
Mã: 
Sub Main()
  Dim Arr
  Arr = UniqueList(Range("L4:Z23"), Range("L31:Z50"))
  If IsArray(Arr) Then Range("B2").Resize(, UBound(Arr) + 1).Value = Arr
End Sub
Nhấp chuột vào đây để mở rộng...
Trời, em chưa để ý bác
ndu96081631
à, code này thuận tiện quá bác ndu96081631 à, Không phải thêm nhiều vòng lặp mà vẫn dồn cho nhiều mảng, bác bận tâm thêm cho em dòng xoa dữ cũ liệu vào với nhé, Cảm ơn bác!
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

N
  • Question Question
Nhờ mọi người giúp em kiểm tra dữ liệu không đúng định dạng từ sheet ban đầu ạ (4 người xem)
Trả lời
2
Đọc
33
nguyenvantu29
N
tranaidh
Giúp sắp xếp phòng thi tốt nghiệp năm 2025 (1 người xem)
Trả lời
1
Đọc
79
tranaidh
tranaidh
G
  • Question Question
hỏi về cách tiếp cận, gán dữ liệu với các Control không tên ( UserForm ) (1 người xem)
Trả lời
0
Đọc
26
giaoluu1231
G
D
Nhờ các A/C trợ giúp căng quá ạ (1 người xem)
Trả lời
0
Đọc
17
dannguyen@oda
D
ankhanh2k2
sắp xếp dữ liệu chấm công
    • Buồn
Trả lời
6
Đọc
130
ptm0412
ptm0412
H
Không hiển thị hết kí tự khi dùng mail merge
Trả lời
19
Đọc
31K
nghiahandsome1995
nghiahandsome1995
nghiahandsome1995
  • Question Question
in đậm chuỗi văn bản bằng excel (1 người xem)
Trả lời
8
Đọc
205
nghiahandsome1995
nghiahandsome1995
PhanTuHuong
Hà Nội hẹn hò gặp gỡ đầu năm 2025 thôi :)
    • Thích
Trả lời
2
Đọc
127
PhanTuHuong
PhanTuHuong
Đỗ Tú Anh
♪♫♪ ~ Thư Giãn Với Âm Nhạc ~ ♫♪♫ (1 người xem)
    • Thích
21 22 23
Trả lời
447
Đọc
11K
Đỗ Tú Anh
Đỗ Tú Anh
S
  • Question Question
Nhờ Mọi người giúp đỡ gộp nhiều dòng thành 1 dòng nhiều cột trong Power Query.
Trả lời
3
Đọc
146
DeTong
D
dangvandang
  • Question Question
Chia sẻ tích hợp trí tuệ nhân tạo (AI) vào excel
    • Thích
Trả lời
8
Đọc
2K
dangvandang
dangvandang
HeSanbi
  • Question Question
Công cụ tạo và chỉnh sửa Ribbon ngay trên Excel (Bản Việt hóa)
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
10
Đọc
6K
HeSanbi
HeSanbi
N
  • Question Question
Xin code link dữ liệu VBA ạ !
Trả lời
1
Đọc
102
BuiQuangThuan
B
T
Bảng tính trợ cấp theo Nghị định 178 và tính lương hưu (1 người xem)
    • Thích
Trả lời
7
Đọc
475
trung_bhxh
T
toanthinh
Công thức tính tuổi âm lịch (1 người xem)
Trả lời
3
Đọc
123
toanthinh
toanthinh
S
Cần hỗ trợ xử lý hiện ngày sản phẩm bằng VBA
Trả lời
0
Đọc
69
sonminhtran
S
GPE-Trợ Lý
[GPE] TALK SHOW EXCEL TRONG SẢN XUẤT (4 người xem)
    • Thích
Trả lời
2
Đọc
841
GPE-Trợ Lý
GPE-Trợ Lý
Nguyễn Duy Tuân
Phiên bản mới Add-in A-Tools v10 (2024)
    • Thích
2 3
Trả lời
40
Đọc
3K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
T
  • Question Question
Mong mọi người giúp đỡ em trường hợp này với ạ.
Trả lời
1
Đọc
135
thanhduybg92
T
T
Bảng tính trợ cấp theo Nghị định 178 và tính lương hưu
    • Thích
Trả lời
1
Đọc
91
vn72259
V
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
TALK SHOW EXCEL TRONG SẢN XUẤT
Back
Top Bottom