Dùng VBA dò tìm vị trí để dán dữ liệu

Chia sẻ bởi:hands

★★★★★

‹ Dò tìm thông tin theo mã khách... Chia lớp theo học lực ›

Quảng cáo

Mọi người ơi giúp em với ạ, em đang muốn dùng VBA tìm vị trí chữ cái xuất hiện lần đầu tiên của cột A (các chữ cái chạy theo thứ tự như cột K), sau đó copy vùng M1:N50 vào vị trí xuất hiện lần đầu tiên của chữ cái đó và xóa vùng thừa như ví dụ ạ

1. Đọc M1:N50 vào một mảng mang
2. Vòng lặp theo từng Cell của cột K
2.1 Dùng Find, Match gì đó, tìm trị của Cell trong cột A
2.2 Nếu tìm được thì gán mảng mang vào cột B
2.3 Ghi nhớ ký tự vừa gán, và vị trí ký tự ấy
3. Từ vị trí đã ghi nhớ, đọc cột A cho đến khi hết ký tự đã ghi nhớ, tức là gặp ký tự khác hoặc trống. Đếm được bao nhiêu dòng (n).
4. Xóa 50-n+1 dòng ở B:C

Dạ em cám ơn ạ, anh có thể chỉ em thêm tí được không do em mới tìm hiểu VBA nên code còn chưa logic ạ

Do bạn "mới bắt đầu học VBA" nên tôi giả thiết là bạn không biết viết code ngay cả khi có gợi ý. Vậy thì hoặc không giúp (không có thời gian, không có hứng cầy từ A đến Z) hoặc giúp từ A đến Z. Tôi từng đọc thấy người ta gọi những kẻ giúp từ A đến Z là rỗi hơi. Mỗi người đều độc lập và tự chủ trong mỗi quyết định của mình. Tôi không bắt ai phải làm từ A đến Z như mình. Và chả ai có quyền chế diễu tôi khi tôi muốn giúp từ A đến Z. Thôi kệ.

Mỗi bài Toán có nhiều cách giải. Nếu bạn đảm bảo là các chữ cái trong cột A đều xuất hiện trong cột K thì chả cần xét cột K. Nếu trong cột A do sơ suất có thể có chữ cái không có trong cột K thì phải sửa code ở dưới.

Ta sẽ xác định vị trí xuất hiện đầu tiên của mỗi chữ cái trong cột A bằng cách so sánh với chucai_hienhanh (ở thời điểm chào buổi sáng chucaihienhanh = RỖNG). Nếu khác thì đó là vị trí đầu tiên của chữ cái.

Việc của bạn chỉ có nghĩa khi các chữ cái trong cột A được sắp xếp, không cần phải tăng dần, có thể là giảm dần, miễn là được sắp xếp.
Code phục vụ cả trường hợp dữ liệu cột A có dòng trống.

Phân tích code sẽ thấy code chạy cho cả những trường hợp cột A không chứa chữ cái 1 ký tự mà chứa câu từ bất kỳ.

Code như sau. Tôi chỉ kiểm tra 3 lần, hi vọng code không bị lỗi.

Option Explicit

Sub dan_DL()
Dim lastRow As Long, r As Long, k As Long, start As Long, text As String, chucai_hienhanh As String, cotAC(), kq()
    With ThisWorkbook.Worksheets("Sheet1")
        .Range("B1:C" & .Range("B" & Rows.Count).End(xlUp).Row).ClearContents   ' xoa ket qua cu
        lastRow = .Range("M" & Rows.Count).End(xlUp).Row
        If lastRow = 1 And .Range("M1").Value = "" Then Exit Sub    ' neu khong co du lieu cot M thi nghi choi
        kq = .Range("M1:N" & lastRow).Value
        lastRow = .Range("A" & Rows.Count).End(xlUp).Row
        If lastRow = 1 And .Range("A1").Value = "" Then Exit Sub    ' neu cot A khong co du lieu thi don do choi
        cotAC = .Range("A1:C" & lastRow + 1).Value   ' lay du 1 dong cuoi, lay 3 cot A:C
    End With
    cotAC(UBound(cotAC, 1), 1) = "Ngay mai em di"   ' nhap chu bat ky vao cuoi mang cotAC de danh dau dong ket thuc cua du lieu cuoi cung trng cot A
    For r = 1 To UBound(cotAC, 1)
        text = cotAC(r, 1)
        If text <> chucai_hienhanh Then
            If chucai_hienhanh <> "" Then
                For k = 1 To r - start  ' ghi cac dong tu start toi (r-1)
                    cotAC(start - 1 + k, 2) = kq(k, 1)  ' ghi cot M vao cot B
                    cotAC(start - 1 + k, 3) = kq(k, 2)  ' ghi cot N vao cot C
                Next k
            End If
            start = r
            chucai_hienhanh = text
        End If
    Next r
    ThisWorkbook.Worksheets("Sheet1").Range("A1:C" & lastRow).Value = cotAC
End Sub

Em xin mạo muội gửi đáp án của mình.
Dự định tháng sau xây nhà nên các bác có ủng hộ thêm ít gạch đá thì welcome ạ.
Cột A có thể sort hay không sort, tùy.

Option Explicit
Sub dan_DL()
Range("B1:C1000000").ClearContents
Range("A1:C" & Cells(Rows.Count, "A").End(xlUp).Row).SpecialCells(xlCellTypeBlanks).Formula = _
"=INDEX(M$1:M$50,COUNTIF($A$1:$A1,$A1))"
End Sub

Góp vui

Sub ABC()
  Dim arr(), arr2(), res$(), sRow&, sRow2&, i&, k&, tmp

With ThisWorkbook.Worksheets("Sheet1")
    If .Range("A1").Value = Empty Then Exit Sub
    .Range("B1", .Range("C" & Rows.Count).End(xlUp)).ClearContents
    arr = .Range("M1", .Range("N" & Rows.Count).End(xlUp)).Value
    arr2 = .Range("A1:B" & .Range("A" & Rows.Count).End(xlUp).Row).Value
    sRow = UBound(arr): sRow2 = UBound(arr2)
    ReDim res(1 To sRow2, 1 To 2)
    For i = 1 To sRow2
      If tmp <> arr2(i, 1) Then k = 0: tmp = arr2(i, 1)
      k = k + 1
      res(i, 1) = arr(k, 1)
      res(i, 2) = arr(k, 2)
    Next i
    .Range("B1").Resize(sRow2, 2) = res
  End With
End Sub

www.giaiphapexcel.com/diendan/threads/d%C3%B9ng-vba-d%C3%B2-t%C3%ACm-v%E1%BB%8B-tr%C3%AD-%C4%91%E1%BB%83-d%C3%A1n-d%E1%BB%AF-li%E1%BB%87u.161621/post-1079559

Cũng xin góp vui thêm 1 cách khác. Code theo ý hiểu bản thân. Không quan tâm tới việc

Sub ABC()
Dim Rng As Range, i&, iR&
Application.ScreenUpdating = False
Set Rng = Sheet1.Range("M1:N51")
With Sheet1
    iR = .Range("A" & Rows.Count).End(3).Row
    For i = 1 To iR
        If Application.WorksheetFunction.CountIf(.Range("A1:A" & i), .Range("A" & i)) = 1 Then
            Rng.Copy
            .Range("D" & i).PasteSpecial xlPasteValues
        End If
    Next
    .Range("D" & iR + 1).Resize(1000, 2).ClearContents
End With
Application.ScreenUpdating = True
End Sub