Trích xuất bảng dữ liệu (VBA)

nhthang277 · 5/4/22

Nhờ anh chị giúp đỡ code cho việc trích xuất dữ liệu theo yêu cầu file đính kèm với ạ.
Em cảm ơn.

vanaccex · 5/4/22

nhthang277 đã viết:
Nhờ anh chị giúp đỡ code cho việc trích xuất dữ liệu theo yêu cầu file đính kèm với ạ.
Em cảm ơn.

Bạn thử dùng cách này không dùng VBA xem

Ngày mai trời lại sáng · 5/4/22

nhthang277 đã viết:
Nhờ anh chị giúp đỡ code cho việc trích xuất dữ liệu theo yêu cầu file đính kèm với ạ.
Em cảm ơn.

Bạn dùng tạm trong khi chờ đợi cách khác gọn hơn

Mã:

Option Explicit

Sub NMTLS()
    Dim dict As Object, BanDau As Variant, XuatRa As Variant, sKey As String, ws As Worksheet
    Dim i As Integer, r As Integer, j As Integer, k As Integer, c As Integer
    Set dict = CreateObject("Scripting.Dictionary")
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    r = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
    If r < 3 Then Exit Sub
    BanDau = ws.Range("C3:D" & r).Value
    r = UBound(BanDau, 1):   ReDim XuatRa(1 To r, 1 To 2)
    For i = LBound(BanDau, 1) To UBound(BanDau, 1)
        sKey = BanDau(i, 1)
        If Not dict.Exists(sKey) Then
            c = c + 1
            dict.Add sKey, c
            XuatRa(c, 1) = sKey
            XuatRa(c, 2) = BanDau(i, 2)
            k = 2
            XuatRa(c, k) = BanDau(i, 2)
        Else
            k = k + 1
            If k > UBound(XuatRa, 2) Then ReDim Preserve XuatRa(1 To r, 1 To k)
            j = dict.Item(sKey)
            If XuatRa(j, k) <> Empty Then
                k = k + 1
                If k > UBound(XuatRa, 2) Then ReDim Preserve XuatRa(1 To r, 1 To k)
            End If
            XuatRa(j, k) = BanDau(i, 2)
        End If
    Next i
    ws.Range("H9").Resize(c, UBound(XuatRa, 2)) = XuatRa
End Sub

BuiQuangThuan · 5/4/22

nhthang277 đã viết:
Nhờ anh chị giúp đỡ code cho việc trích xuất dữ liệu theo yêu cầu file đính kèm với ạ.
Em cảm ơn.

Thêm 1 cách khác tham khảo:

Mã:

Sub ABC()
Dim Dic As Object, sArr(), Res(), i&, iRow&, J&, K&, Max&
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet1
    iRow = .Range("C" & Rows.Count).End(3).Row
    .Range("C3:D" & iRow).Sort .Range("C2"), xlAscending
    sArr = .Range("C3:D" & iRow).Value
End With
ReDim Res(1 To UBound(sArr, 1), 1 To UBound(sArr, 1))
For i = 1 To UBound(sArr, 1)
    J = J + 1
    If Dic.exists(sArr(i, 1)) = False Then
        If Max > J Then Max = Max Else Max = J
        K = K + 1: J = 1
        Dic.Item(sArr(i, 1)) = K
        Res(K, 1) = sArr(i, 1)
        Res(K, J + 1) = sArr(i, 2)
    Else
        Res(Dic.Item(sArr(i, 1)), J + 1) = sArr(i, 2)
    End If
Next
Sheet1.Range("H14").Resize(K, Max).Value = Res
End Sub

Maika8008 · 5/4/22

nhthang277 đã viết:
Nhờ anh chị giúp đỡ code cho việc trích xuất dữ liệu theo yêu cầu file đính kèm với ạ.
Em cảm ơn.

Lưu item và số đếm cột vào 1 mảng.

Rich (BB code):

Sub GPE()
    Dim dic As Object, i&, k&, imax&
    Dim aData, aRes, aKey, sKey$
    Set dic = CreateObject("Scripting.Dictionary")
    aData = Sheet1.Range("C3:D" & Sheet1.Range("C" & Rows.Count).End(xlUp).Row).Value
    ReDim aRes(1 To UBound(aData), 1 To UBound(aData))
    ReDim aKey(1 To UBound(aData), 1 To 2)
    For i = 1 To UBound(aData)
        sKey = aData(i, 1)
        If Not dic.Exists(sKey) Then
            k = k + 1
            aKey(k, 1) = k: aKey(k, 2) = 2
            dic.Add sKey, aKey(k, 1)
            aRes(aKey(k, 1), 1) = sKey
            aRes(aKey(k, 1), aKey(k, 2)) = aData(i, 2)
        Else
            aKey(dic.Item(sKey), 2) = aKey(dic.Item(sKey), 2) + 1
            If imax < aKey(dic.Item(sKey), 2) Then imax = aKey(dic.Item(sKey), 2)
            aRes(dic.Item(sKey), aKey(dic.Item(sKey), 2)) = aData(i, 2)
        End If
    Next i
    Sheet1.Range("H9").Resize(k, imax) = aRes
    Set dic = Nothing
End Sub

BuiQuangThuan · 5/4/22

Maika8008 đã viết:
Lưu item và số đếm cột vào 1 mảng.

Cách này hay này. Nhưng akey với sKey nó na ná nhau quá. Đọc muốn rối não luôn mất.

Maika8008 · 5/4/22

BuiQuangThuan đã viết:
Cách này hay này. Nhưng akey với sKey nó na ná nhau quá. Đọc muốn rối não luôn mất.

Sửa thành aCol vậy:

Rich (BB code):

Sub GPE()
    Dim dic As Object, i&, k&, imax&
    Dim aData, aRes, aCol, sKey$
    Set dic = CreateObject("Scripting.Dictionary")
    aData = Sheet1.Range("C3:D" & Sheet1.Range("C" & Rows.Count).End(xlUp).Row).Value
    ReDim aRes(1 To UBound(aData), 1 To UBound(aData))
    ReDim aCol(1 To UBound(aData), 1 To 2)
    For i = 1 To UBound(aData)
        sKey = aData(i, 1)
        If Not dic.Exists(sKey) Then
            k = k + 1
            aCol(k, 1) = k: aCol(k, 2) = 2
            dic.Add sKey, aCol(k, 1)
            aRes(aCol(k, 1), 1) = sKey
            aRes(aCol(k, 1), aCol(k, 2)) = aData(i, 2)
        Else
            aCol(dic.Item(sKey), 2) = aCol(dic.Item(sKey), 2) + 1
            If imax < aCol(dic.Item(sKey), 2) Then imax = aCol(dic.Item(sKey), 2)
            aRes(dic.Item(sKey), aCol(dic.Item(sKey), 2)) = aData(i, 2)
        End If
    Next i
    Sheet1.Range("H9").Resize(k, imax) = aRes
    Set dic = Nothing
End Sub

BuiQuangThuan · 5/4/22

Maika8008 đã viết:
Sửa thành aCol vậy

Anh cẩn thận quá. Em cám ơn đã chỉ điểm. Thấy code sịn sò quá.

HUONGHCKT · 5/4/22

Góp vui. thêm 1 cách củ chuối này cho bạn tham khảo.
hãy nhập địa chỉ (dòng và cột vào ô O1 và O2) và nhấn mặt cười, xem kết quả. hãy thử thêm bớt dữ liệu và chạy thử xem.

Mã:

Option Explicit

Sub Tach()
Dim i&, R&, C&, d&, LastRow&
Dim Arr()
Dim Dic As Object, key
Dim ws As Worksheet

Application.ScreenUpdating = False

Set ws = Sheets("Sheet1")
R = ws.[O1] - 1: C = ws.[O2]
ws.Cells(R, C).Resize(1000, 1000).ClearContents
LastRow = ws.Cells(Rows.Count, 3).End(xlUp).Row
If LastRow <= 3 Then Exit Sub
Arr = ws.Range("C3", "D" & LastRow).Value
Set Dic = CreateObject("Scripting.Dictionary")

For i = 1 To UBound(Arr)
    key = Arr(i, 1)
        If Not Dic.Exists(key) Then
            R = R + 1: Dic.Add (key), R
            ws.Cells(R, C) = key: ws.Cells(R, C).Offset(0, 1) = Arr(i, 2)
        Else
            d = Dic.Item(key)
            ws.Cells(d, ws.Cells(d, C).End(xlToRight).Column + 1) = Arr(i, 2)
        End If
Next i
Set Dic = Nothing
  Application.ScreenUpdating = True
  MsgBox "OK", vbInformation, "THÔNG BÁO"
End Sub

BuiQuangThuan · 5/4/22

HUONGHCKT đã viết:

Góp vui. thêm 1 cách củ chuối này cho bạn tham khảo.
hãy nhập địa chỉ (dòng và cột vào ô O1 và O2) và nhấn mặt cười, xem kết quả. hãy thử thêm bớt dữ liệu và chạy thử xem.

Mã:

Option Explicit

Sub Tach()
Dim i&, R&, C&, d&, LastRow&
Dim Arr()
Dim Dic As Object, key
Dim ws As Worksheet

Application.ScreenUpdating = False

Set ws = Sheets("Sheet1")
R = ws.[O1] - 1: C = ws.[O2]
ws.Cells(R, C).Resize(1000, 1000).ClearContents
LastRow = ws.Cells(Rows.Count, 3).End(xlUp).Row
If LastRow <= 3 Then Exit Sub
Arr = ws.Range("C3", "D" & LastRow).Value
Set Dic = CreateObject("Scripting.Dictionary")

For i = 1 To UBound(Arr)
    key = Arr(i, 1)
        If Not Dic.Exists(key) Then
            R = R + 1: Dic.Add (key), R
            ws.Cells(R, C) = key: ws.Cells(R, C).Offset(0, 1) = Arr(i, 2)
        Else
            d = Dic.Item(key)
            ws.Cells(d, ws.Cells(d, C).End(xlToRight).Column + 1) = Arr(i, 2)
        End If
Next i
Set Dic = Nothing
  Application.ScreenUpdating = True
  MsgBox "OK", vbInformation, "THÔNG BÁO"
End Sub

ớ. chú chơi thẳng xuống sheet luôn cơ hả?

Bài đã được tự động gộp: 5/4/22

@HUONGHCKT cái cột + Dòng chú quy định trong sheet ấy có ý nghĩa gì ấy nhỉ

HUONGHCKT · 5/4/22

BuiQuangThuan đã viết:
ớ. chú chơi thẳng xuống sheet luôn cơ hả?

Mình nói rồi code rất củ chuối mà. Vừa dùng Dic, vừa dùng mảng, vừa tẹt luôn xuống sheet. Nhưng được cái là chạy đúng. kể cả các tên (cột C) xếp Trùng nhau nhiều và lộn xộn thì kết quả vẫn cứ tuần tự, dữ liệu Dx được gối liên tiếp liền kề nhau không cách quãng ở vùng kết quả.

BuiQuangThuan · 5/4/22

HUONGHCKT đã viết:
Mình nói rồi code rất củ chuối mà. Vừa dùng Dic, vừa dùng mảng, vừa tẹt luôn xuống sheet. Nhưng được cái là chạy đúng. kể cả các tên (cột C) xếp Trùng nhau nhiều và lộn xộn thì kết quả vẫn cứ tuần tự, dữ liệu Dx được gối liên tiếp liền kề nhau không cách quãng ở vùng kết quả.

Chú lại khiêm tốn rồi. Thực ra tiêu chuẩn củ chuối của chú là vậy chứ với người khác như cháu á. Thì nó không phải củ chuối đâu chú ạ.

Hoàng Tuấn 868 · 5/4/22

BuiQuangThuan đã viết:
Chú lại khiêm tốn rồi. Thực ra tiêu chuẩn củ chuối của chú là vậy chứ với người khác như cháu á. Thì nó không phải củ chuối đâu chú ạ.

Củ Sâm đấy . . .

HUONGHCKT · 5/4/22

BuiQuangThuan đã viết:
Chú lại khiêm tốn rồi. Thực ra tiêu chuẩn củ chuối của chú là vậy chứ với người khác như cháu á. Thì nó không phải củ chuối đâu chú ạ.

Mình cũng theo dõi và đọc code của bạn nhiều rồi, mình biết chứ, trình của bạn về Excel nói chung và VBA nói riêng cao hơn mình nhiều lần.

BuiQuangThuan · 5/4/22

@HUONGHCKT haha. ngồi coi code của chú. Chú chưa định hình được cột để gán kết quả cho item trong Dic nên chú mới sử dụng gán xuống sheet xác định cột. Hihi
Cũng là 1 cách hay á. Lỡ đứa nào nó cho dữ liệu ở cột thứ 1009 thì dở chú nhỉ? hihi :1a:

Bài đã được tự động gộp: 5/4/22

Hoàng Tuấn 868 đã viết:
Củ Sâm đấy . . .

Đúng. Phải là củ Sâm ấy anh ạ

HUONGHCKT · 5/4/22

BuiQuangThuan đã viết:
@HUONGHCKT haha. ngồi coi code của chú. Chú chưa định hình được cột để gán kết quả cho item trong Dic nên chú mới sử dụng gán xuống sheet xác định cột. Hihi
Cũng là 1 cách hay á. Lỡ đứa nào nó cho dữ liệu ở cột thứ 1009 thì dở chú nhỉ? hihi

Bài đã được tự động gộp: 5/4/22

Đúng. Phải là củ Sâm ấy anh ạ

Tôi làm nhiều cách mà không được, phần kết quả trả về nó cứ bị cách quãng không liên tục nên đành phải làm cách củ chuối ấy(củ chuối thật chứ củ gì đâu). Thôi thì kết quả trả về đúng ý mình là được (có có thể lại là không đúng ý của chủ thớt). Mình trình độ lùn thì viết được ra kết quả là mừng rồi cho dù có phải đi đường vòng, code dài, chậm,...

SA_DQ · 5/4/22

Rảnh quá nên không xài Dic nè:

PHP:

Sub LapDSDN()
 Dim Arr(), Cls As Range
 Dim Rws As Long, W As Integer, J As Long
      
 [H3].CurrentRegion.Delete
 Rws = [C3].CurrentRegion.Rows.Count
 Range("C3").Resize(Rws).Copy Destination:=[H3]
 Range("H3").CurrentRegion.Select
 Selection.RemoveDuplicates Columns:=1, Header:=xlNo
 Arr() = [C3].Resize(Rws, 2).Value
 For Each Cls In [H3].CurrentRegion
    ReDim aKQ(1 To 1, 1 To Rws)
    For J = 1 To UBound(Arr())
        If Cls.Value = Arr(J, 1) Then
            W = W + 1:          aKQ(1, W) = Arr(J, 2)
        End If
    Next J
    If W Then
        Cls.Offset(, 1).Resize(, W).Value = aKQ()
        W = 0
    End If
 Next Cls
 [H2].Value = Left([c2].Value, 8) & "Sau:"
End Sub

HieuCD · 5/4/22

Code của các bạn ngày càng hay

thêm các lệnh sort kết quả theo cột của từng dòng là hoàn hảo theo kết quả mẩu

b

5

6

VetMini · 5/4/22

SA_DQ đã viết:
Rảnh quá nên không xài Dic nè:
...

Không đít sần thì À Đĩ Ổ mới đúng thông lệ GPE chứ.

HieuCD · 6/4/22

Sort dữ liệu theo 2 cột, xử lý trở nên đơn giản

Mã:

Option Explicit
Sub ABC()
  Dim sArr(), res(), sRow&, i&, k&, j&, tmp$, sCol&
  With Sheets("Sheet1")
    res = .Range("C3", .Range("D" & Rows.Count).End(xlUp)).Value
    sRow = UBound(res)
    .Range("C3").Resize(sRow, 2).Sort .Range("C3"), 1, .Range("D3"), , 1, Header:=xlNo
    sArr = .Range("C3").Resize(sRow, 2).Value
    .Range("C3").Resize(sRow, 2).Value = res
  End With
  ReDim res(1 To sRow, 1 To sRow)
  For i = 1 To sRow
    If tmp <> sArr(i, 1) Then
      If sCol < j Then sCol = j
      tmp = sArr(i, 1)
      k = k + 1: j = 1
      res(k, 1) = tmp
    End If
    j = j + 1
    res(k, j) = sArr(i, 2)
  Next i
  Sheet1.Range("H7").Resize(k, sCol) = res
End Sub

Trích xuất bảng dữ liệu (VBA)

Thành viên mới

File đính kèm

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

File đính kèm

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

❆❆❆❆❆❆❆❆❆❆❆❆

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

❆❆❆❆❆❆❆❆❆❆❆❆

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

❆❆❆❆❆❆❆❆❆❆❆❆

Zalo 0986997214

File đính kèm

❆❆❆❆❆❆❆❆❆❆❆❆

Zalo 0986997214

❆❆❆❆❆❆❆❆❆❆❆❆

Đăng ký hôm qua

Zalo 0986997214

❆❆❆❆❆❆❆❆❆❆❆❆

Zalo 0986997214

/(hông là gì!

Chuyên gia GPE

Ăn cùng góc phố

Chuyên gia GPE