Chuyên đề Bài tập VBA

Liên hệ QC
SA_DQ

SA_DQ

/(hông là gì!
Thành viên danh dự
Tham gia
8/6/06
Bài viết
14,322
Được thích
22,366
Nghề nghiệp
Nuôi ba ba & trùn quế
Bài I: Chuyển dữ liệu từ 1 bảng tổng hợp​
Số liệu ban đầu như sau:
| A | B 1 |Project1|Item01, Item03, Item08, Item09
2 |Project2|Item10, Item30, Item80, Item90
(Bảng 1)

Giờ muốn có 1 macro để chuyển bảng dữ liệu này thành bảng sau:
|D | E 1 |Project1|Item01
2 |Project1|Item03
3 |Project1|Item08
4 |Project1|Item09
5| Project2|Item10
. . .|. . .
8 |Project2|Item90

(Bảng 2)
Bài II: Hãy giúp tôi chuyển dữ liệu từ bảng 2 thành bảng 1 ​
(húc Mừng Xuân Mới! ​
 
Chỉnh sửa lần cuối bởi điều hành viên:
Sắp xếp theo thời gian sắp xếp theo bầu chọn
kyo làm còn sơ sài, rất mong được mọi người góp ý
Đây là bài 1
PHP: 
Sub bt1()
Dim arr
Dim i As Integer, j As Integer, k As Integer
i = 1
k = 1
Do Until Sheet1.Range("B" & i).Value = ""
    arr = Split(Sheet1.Range("B" & i).Value, ", ")
    For j = LBound(arr) To UBound(arr)
        Sheet1.Range("D" & k).Value = Sheet1.Range("A" & i).Value
        Sheet1.Range("E" & k).Value = arr(j)
        k = k + 1
    Next j
    i = i + 1
Loop
End Sub

Đây là bài 2
PHP: 
Sub bt2()
Dim i As Integer, j As Integer
i = 2
j = 1
Sheet1.Range("A" & j).Value = Sheet1.Range("D" & j).Value
Sheet1.Range("B" & j).Value = Sheet1.Range("E" & j).Value
Do Until Sheet1.Range("E" & i).Value = ""
    If Sheet1.Range("D" & i).Value = Sheet1.Range("D" & i - 1).Value Then
        Sheet1.Range("B" & j).Value = Sheet1.Range("B" & j).Value & ", " & Sheet1.Range("E" & i).Value
    Else
        j = j + 1
        Sheet1.Range("A" & j).Value = Sheet1.Range("D" & i).Value
        Sheet1.Range("B" & j).Value = Sheet1.Range("E" & i).Value
    End If
    i = i + 1
Loop
End Sub
 
Upvote 0
kyo đã viết:
kyo làm còn sơ sài, rất mong được mọi người góp ý
Nhấp chuột vào đây để mở rộng...

Do Loop như vậy là chuẩn rồi. Nhưng có 1 số ý kiến thế này:

1. Nếu vẫn đánh vào sheet từng ô một:
Sử dụng With - End With để khỏi lập đi lập lại sheet1.Range(...

2. Nên dùng mảng để tăng tốc độ.
Vì theo thuật toán trên, không chỉ đánh từng ô trong sheet, mà mỗi ô còn bị đánh mấy lần!

3. Có 2 dòng lệnh lập lại giống nhau bên ngoài Do và bên trong Do, có thể gộp hết vào trong Do?
 
Lần chỉnh sửa cuối:
Upvote 0
Bài 2B giành cho các thành viên dưới 500 bài viết & chưa có bài trong topic này

Mình có bảng dữ liệu sau:

1|Cha | Con 2 |AA|01
3 |AA|03
4 |AA|08
5 |AA|09
5| AA|10
6 |AA|A1
7 |CC|GPE
8 |BA|90
9 |BA|09
10| BA|10
11 |BA|A1
12 |BA|10
13|CC|Z1

Bằng macro nào để chuyển dữ liệu thành bảng sau:

| E | F 1 | Cha | Con 2 |AA|01, 03, 08, 09, 10, A1
3 |CC|GPE, Z1
4 |BA|90, 09, 10, A1, 10


(húc Mừng Xuân Mới!

​
 
Upvote 0
ptm0412 đã viết:
Do Loop như vậy là chuẩn rồi. Nhưng có 1 số ý kiến thế này:

1. Nếu vẫn đánh vào sheet từng ô một:
Sử dụng With - End With để khỏi lập đi lập lại sheet1.Range(...

2. Nên dùng mảng để tăng tốc độ.
Vì theo thuật toán trên, không chỉ đánh từng ô trong sheet, mà mỗi ô còn bị đánh mấy lần!

3. Có 2 dòng lệnh lập lại giống nhau bên ngoài Do và bên trong Do, có thể gộp hết vào trong Do?
Nhấp chuột vào đây để mở rộng...
Cám ơn chú đã góp ý cho con, con xin tiếp thu và sửa chữa. Về phần mảng thì con có hơi mù mờ với nó nên vẫn chưa có áp dụng nhiều, con sẽ cố gắng nghiên cứu nó.

Với bài tập tiếp theo, thuật toán có hơi dài một chút vì giờ kyo vẫn chưa nghĩ ra được thuật toán nào khác +-+-+-++-+-+-++-+-+-+
PHP: 
Sub bt3()
Dim i As Integer, j As Integer, check As Boolean
i = 2
j = 1
With Sheet1
    .Range("E" & j).Value = .Range("A" & j).Value
    .Range("F" & j).Value = .Range("B" & j).Value
    Do Until .Range("B" & i).Value = ""
        If .Range("A" & i).Value = .Range("E" & j).Value Then
            .Range("F" & j).Value = .Range("F" & j).Value & ", " & .Range("B" & i).Value
        Else
            check = False
            EndR = .Range("E65000").End(xlUp).Row
            For j = 1 To EndR
                If .Range("A" & i).Value = .Range("E" & j).Value Then
                    .Range("F" & j).Value = .Range("F" & j).Value & ", " & .Range("B" & i).Value
                    check = True
                    Exit For
                End If
            Next j
            If check = False Then
                .Range("E" & j).Value = .Range("A" & i).Value
                .Range("F" & j).Value = .Range("B" & i).Value
            End If
        End If
        i = i + 1
    Loop
End With
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Bài 2C hệt bài 2B đây ạ!

Có bảng dữ liệu sau:

1 | Cha | Con 2 |Hoa|Cúc
3 |Hoa|Mai
4 |Hoa|Đào
5 |Hoa|Hồng
5| Hoa|Táo
6 |Hoa|Thược dượt
7 |Mùa|Mưa
8 |Trái|Cam
9 |Trái|Quýt
10| Trái|Măng cụt
11 |Trái|Bưỡi
12 |Trái|Táo
13 |Mùa|Khô

Bằng macro nào để chuyển dữ liệu thành bảng sau:

| E | F 1 | Cha | Các con
 2 |Hoa|Cúc, Mai, Đào, Hồng, Táo & Thược dượt
3 |Mùa|Mưa & Khô
4 |Trái|Cam, Quýt, Măng cụt, Bưỡi & Táo
(húc Mừng Xuân Mới!
​
 
Lần chỉnh sửa cuối:
Upvote 0
kyo đã viết:
+-+-+-+
PHP: 
Sub bt3()
Dim i As Integer, j As Integer, check As Boolean
i = 2
j = 1
With Sheet1
    .Range("E" & j).Value = .Range("A" & j).Value
    .Range("F" & j).Value = .Range("B" & j).Value
    Do Until .Range("B" & i).Value = ""
        If .Range("A" & i).Value = .Range("E" & j).Value Then
            .Range("F" & j).Value = .Range("F" & j).Value & ", " & .Range("B" & i).Value
        Else
            check = False
            EndR = .Range("E65000").End(xlUp).Row
            For j = 1 To EndR
                If .Range("A" & i).Value = .Range("E" & j).Value Then
                    .Range("F" & j).Value = .Range("F" & j).Value & ", " & .Range("B" & i).Value
                    check = True
                    Exit For
                End If
            Next j
            If check = False Then
                .Range("E" & j).Value = .Range("A" & i).Value
                .Range("F" & j).Value = .Range("B" & i).Value
            End If
        End If
        i = i + 1
    Loop
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Những bài dạng thế này thì phải nghĩ ngay đến tạo 1 dm duy nhất ở cột Cha. Sau đó duyệt qua danh mục trên và lấy cột Con.
Mà dm duy nhất nếu chưa dùng Dic thì có thể dùng.
- Countif
- AdFilter. Theo tôi nên dùng cái này.
 
Upvote 0
Upvote 0
kyo đã viết:
Đây là bài 2
PHP: 
Sub bt2()
Dim i As Integer, j As Integer
i = 2
j = 1
Sheet1.Range("A" & j).Value = Sheet1.Range("D" & j).Value
Sheet1.Range("B" & j).Value = Sheet1.Range("E" & j).Value
Do Until Sheet1.Range("E" & i).Value = ""
    If Sheet1.Range("D" & i).Value = Sheet1.Range("D" & i - 1).Value Then
        Sheet1.Range("B" & j).Value = Sheet1.Range("B" & j).Value & ", " & Sheet1.Range("E" & i).Value
    Else
        j = j + 1
        Sheet1.Range("A" & j).Value = Sheet1.Range("D" & i).Value
        Sheet1.Range("B" & j).Value = Sheet1.Range("E" & i).Value
    End If
    i = i + 1
Loop
End Sub
Nhấp chuột vào đây để mở rộng...
Với bài 2, dữ liệu không sort trước thì coi như code.. tèo
Dạng bài này phải dùng Dictionary mới chuẩn (đương nhiên phải kết hợp xử lý Array để tăng tốc)
----------------------
BNTT đã viết:
Hơ.... cái bác ThuNghi này... không đọc kỹ yêu cầu gì hết trơn.
Nhấp chuột vào đây để mở rộng...
Ông Piano này cũng... trên 4000 bài, vậy còn nói người ta
Ẹc... Ẹc...
 
Lần chỉnh sửa cuối:
Upvote 0
ndu96081631 đã viết:
Với bài 2, dữ liệu không sort trước thì coi như code.. tèo
Dạng bài này phải dùng Dictionary mới chuẩn (đương nhiên phải kết hợp xử lý Array để tăng tốc)
Nhấp chuột vào đây để mở rộng...
Code Bt2() dựa vào đề bài 2 ndu ui, đề bài 2 là đã sort, đề 2B mới là chưa sort.
 
Upvote 0
Bác HYen17 ơi, có bài tập nào cho thành viên từ 1500 bài trở lên không ạ? Tự đập đầu 3 cái+-+-+-++-+-+-++-+-+-+
 
Upvote 0
Xin lỗi BeBo nghen!, Xin cụ thể hóa:

Giành cho những người có dưới 500 bài trong BOX lập trình & liên quan!

/-)ược chưa?


(húc xuân vui vẻ!
 
Upvote 0
kyo giải lại bài tập 2b nhưng xài Dic và mảng, có gì mong mọi người tiếp tục góp ý.
PHP: 
Option Base 1
Sub bt2b()
Dim arr(), arrkq()
Dim EndR As Integer, i As Integer, j As Integer, r As Integer
With CreateObject("Scripting.Dictionary")
    j = 0
    r = 0
    EndR = Sheet1.Range("A65000").End(xlUp).Row
    ReDim arr(EndR - 1, 2)
    arr = Sheet1.Range("A2:B" & EndR).Value
    For i = 1 To UBound(arr)
        If Not .Exists(arr(i, 1)) Then
            .Add arr(i, 1), ""
            r = r + 1
            For j = 2 To EndR
                If Sheet1.Range("A" & j).Value = arr(i, 1) Then
                    ReDim Preserve arrkq(2, 1 To r)
                    arrkq(1, r) = arr(j - 1, 1)
                    If arrkq(2, r) = "" Then
                        arrkq(2, r) = arr(j - 1, 2)
                    Else
                        arrkq(2, r) = arrkq(2, r) & ", " & arr(j - 1, 2)
                    End If
                End If
            Next j
        End If
    Next i
    Sheet1.Range("E2").Resize(.Count, 2).Value = WorksheetFunction.Transpose(arrkq)
End With
End Sub
 
Upvote 0
kyo đã viết:
kyo giải lại bài tập 2b nhưng xài Dic và mảng, có gì mong mọi người tiếp tục góp ý.
Nhấp chuột vào đây để mở rộng...
Thuật toán tạm ổn nhưng:
- Dùng 2 vòng lặp For lồng nhau, số lần lặp là bình phương số dòng dữ liệu. Nếu 2 vòng lặp riêng rẽ, số lần lặp là 2 x số dòng dữ liệu
- Nếu khéo, có thể dùng chỉ 1 vòng lặp, vừa tạo Dic, vừa gán kết quả. Số lần lặp vừa bằng số dòng dữ liệu.
- 1 trong 2 vòng lặp vẫn còn đọc cell, chưa đọc trên mảng
- Nên hạn chế dùng transpose.
- Nghiên cứu thêm về Dic.Item(key1)
 
Lần chỉnh sửa cuối:
Upvote 0
Xin đóng góp một cách đơn giản mà không cần dùng đến mảng hay đối tượng ngoài nào cả. Tiếp cận này sử dụng chiến thuật xử lý tuần tự với một mẹo nhỏ - các bạn xem nhé...
(Mẹo ở đây là Với phần tử cha mới thì sẽ lưu vào biến nhớ theo dạng [cha mới]số dòng ghi kết quả tại sheet kết quả, sau đó khi duyệt lại thì chỉ dùng hàm instr để kiểm tra - giống dạng dùng dicobj thôi, nếu có thì lấy số dòng, nếu không thì lại cha mới, dòng mới)
(Các bác thông cảm - không phải vì tiêu chí 400 hay 500 bài đâu ạ), em chỉ xin chia sẻ một cách em hay dùng đối với chuỗi.
PHP: 
Sub Test()
    Application.ScreenUpdating = False
    ' Cach lam theo huong xu ly tuan tu va mot chut meo
    ' Chuoi giu cac phan tu Cha va thu tu dong
    Dim PrcString As String, UseString As String, NewRow As Long, UseRow As Long
    ' Bien danh dau vi tri du lieu da ghi
    Dim xPos As Long
    ' Bien de giu vung duyet
    Dim ChkRange As Range
    Dim ShtSrc As Worksheet
    Dim ShtDst As Worksheet
    Set ShtSrc = Sheet1
    Set ShtDst = Sheet2
    Set ChkRange = ShtSrc.Range("A2")
    ' Dau tien, dong moi se bat dau tu dong 2
    NewRow = 2
    While ChkRange <> ""
        UseString = "[" & ChkRange & "]"
        xPos = InStr(PrcString, UseString)
        If xPos <= 0 Then
            ' Khong ton tai gia tri nay trong chuoi - chuyen sang dong moi va ghi nho dong
            ' Chuyen sang Sheet moi
            PrcString = PrcString & "," & UseString & NewRow
            ShtDst.Range("A" & NewRow) = ChkRange
            ShtDst.Range("B" & NewRow) = ChkRange.Offset(, 1)
            ' Tang dong moi
            NewRow = NewRow + 1
        Else
            ' Ok co trong cum du lieu da xu ly...
            UseRow = Val(Mid(PrcString, xPos + Len(UseString)))
            ShtDst.Range("A" & UseRow) = ChkRange
            ShtDst.Range("B" & UseRow) = ShtDst.Range("B" & UseRow) & ", " & ChkRange.Offset(, 1)
        End If
        Set ChkRange = ChkRange.Offset(1)
    Wend
    Set ChkRange = Nothing
    Set ShtDst = Nothing
    Set ShtSrc = Nothing
    Application.ScreenUpdating = True
End Sub
Thực ra bài giải này chỉ mang tính chất thí dụ về cách tiếp cận các loại đối tượng khác nhau. Việc sử dụng đối tượng nào trong bài toán phụ thuộc nhiều vào thói quen và yêu cầu xử lý của người dùng.
Chân thành cảm ơn các bác đã chú ý và chúc mọi người một cái tết an lành, thành công và hạnh phúc
 
Lần chỉnh sửa cuối:
Upvote 0
Xin lỗi vì đã sửa php code trong bài của Paul, nó bị lỗi gì đó mà không xuống dòng.

Tiếp theo, xin nói ngay rằng, sử dụng mảng nhằm mục đích tăng tốc cho code.

Với kinh nghiệm đọc bài GPE, tôi thấy rằng với dữ liệu nhiều (trên 1000 dòng), việc đọc từng ô tên sheet, xử lý, rồi gán xuống từng ô, thời gian chạy code mất ít nhất là gấp đôi so với dùng mảng.

Nếu dữ liệu là 60.000 dòng, thời gian tiêu tốn gấp 8 đến 10 lần. (Có thể có sai số, tuỳ theo mức độ và số lượng công việc cần xử lý trước khi gán xuống)
 
Upvote 0
Tôi vừa kiểm tra: Test với 13000 cha, 65.000 con:

- Code sử dụng Dictionary và 1 mảng, 2 vòng lặp riêng rẽ: 1.15 giây
- Code sử dụng Dictionary và 1 mảng, 1 vòng lặp: 1.06 giây
- Code của Paul: 76 giây. Hút 1/2 điếu thuốc.
 
Lần chỉnh sửa cuối:
Upvote 0
Hơ.... cái bác ThuNghi này... không đọc kỹ yêu cầu gì hết trơn.
Nhấp chuột vào đây để mở rộng...

(hỉ cấm tham gia bài giải thôi, không cấm hướng dẫn hay gợi í đâu mừ!

/-)úng như ThuNghi nói, bài này có nhiều cách giải cho nhiều đối tượng khác nhau. Nhưng ngay bài giải đầu đã vô mức tương đối rồi, nên chúng ta sẽ khó thấy các bài giải mộc mạc khác . . . . .

Xin lỗi vì đã sửa php code trong bài của Paul, nó bị lỗi gì đó mà không xuống dòng.
Nhấp chuột vào đây để mở rộng...

Cái chuyện này có thể là lỗi của diễn đàn chúng ta; Mình từng gặp fải, một khi sửa chửa bài có xài [php ]. . .[/php] hay [code ]. . . [/code]




(húc )(uân &ui &ẻ!

 
Lần chỉnh sửa cuối:
Upvote 0
Cuối năm rồi tham gia 1 bài coi kết thúc năm cũ mong năm sau mình sẽ tiếp bộ hơn, Chúc cả đại gia đình Giải Pháp Excel năm mới vui vẻ tràn đầy hạnh phúc!!!!!!!
PHP: 
Sub chacon()
Dim dic As Object, iRow As Long, SourceArr As Variant
Dim RArr As Variant, i As Long
Set dic = CreateObject("Scripting.Dictionary")
SourceArr = Range("b2:c14").Value
ReDim RArr(1 To UBound(SourceArr, 1), 1 To UBound(SourceArr, 2))

    For iRow = 1 To UBound(SourceArr, 1)

        If Not dic.Exists(SourceArr(iRow, 1)) Then
            i = i + 1
            
            dic.Add SourceArr(iRow, 1), i
            RArr(i, 1) = SourceArr(iRow, 1)
            RArr(i, 2) = SourceArr(iRow, 2)
           
        Else
        
            RArr(dic.Item(SourceArr(iRow, 1)), 2) = RArr(dic.Item(SourceArr(iRow, 1)), 2) & ", " & SourceArr(iRow, 2)
        
        End If
        
    Next iRow

Range("d12").Resize(i, 2).Value = RArr
End Sub
 

File đính kèm

  • BT2.xls
    45 KB · Đọc: 56
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

Bich2B
lỗi định dạng ngày không đọc được công thức excel
Trả lời
9
Đọc
200
thaiduylamus
thaiduylamus
C
Giúp em viết công thức làm lịch thi đấu.
Trả lời
0
Đọc
11
caocat
C
D
Tính khoảng cách giữa 2 tọa độ?
Trả lời
4
Đọc
61
danhculao
D
pupuchcha
  • Question
Viết code để tìm xích ma, mong mọi người giúp đỡ em ạ
Trả lời
0
Đọc
23
pupuchcha
pupuchcha
K
Nhờ mọi người hỗ trợ giúp mình về tìm kiếm trong VBA. Mình sẽ gửi chút chi phí cafe cám ơn nhiều ạ
    • Cười
Trả lời
18
Đọc
302
VetMini
V
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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

Back
Top Bottom