Chỉnh sửa code để update giá trị bảng 2 sang bảng 1.

Liên hệ QC

TuPham86

Thành viên mới
Tham gia
28/11/19
Bài viết
16
Được thích
0
Em có bài toán muốn nhờ trợ giúp của các bác, bài toán của em là em muốn update giá trị (các cột min 4a, max 4a., min 6a, max6a)từ bảng 2 sang bảng 1, đoạn code em viết ở dưới thì dùng được rồi ạ, nhưng có điều là khi update giá trị vào thì nó được hiểu như là tìm kiếm ví dụ cột min 6a, max 6a và copy (min 6a, max 6a...) cột đó từ bảng 2 sang bảng 1, giờ em muốn nó copy nhưng đọc theo tên lỗ khoan (LKVU-BS1,LKVU-BS2.....) như chữ bôi đỏ bảng 1(e ví dụ tên lỗ khoan ở bảng 1 xếp lộn xộn chỗ bôi đỏ ạ,). Nhờ các bác giúp e với nhé. Em xin chân thành cảm ơn các bác. file và hình ảnh e có đính kèm ở dưới ạ.
Mã:
Sub UpdateRQD()
Dim iRow As Long, iCol As Long, r As Long, c As Long, data(), result(), dic As Object, sh As Worksheet, wb As Workbook
    data = Range("A17:L22").Value
Set dic = CreateObject("Scripting.Dictionary")
dic.comparemode = vbTextCompare
For c = 1 To UBound(data, 2)
    If Not dic.exists(data(1, c)) And data(1, c) <> 0 Then dic.Add data(1, c), c
    Next c

result = Range("A3:R8").Value
        For c = 1 To UBound(result, 2)
    '        neu tieu de co trong mang data thi thuc hien
            If dic.exists(result(1, c)) Then
    '            doc tu dic ra chi so cot trong mang data cua tieu de hien hanh
                iCol = dic.Item(result(1, c))
    '            copy cot curr_col cua mang data sang cot c cua mang result
                For r = 2 To UBound(result)
                    result(r, c) = data(r, iCol)
                Next r
            End If
        Next c
        Range("A3").Resize(UBound(result), UBound(result, 2)).Value = result
        Set dic = Nothing
End Sub

z9uWpOy.png
 

File đính kèm

  • Update.xlsm
    17 KB · Đọc: 6
Mình xin phân tích bài toán của bạn như sau:
(*) Bảng B bạn đang có 2 vùng (cần chép đến bảng A); Mà trong đó mỗi vùng gồm 6 cột với số dòng như nhau (hoặc không như nhau cũng OK)
(**) Bảng A cần được chép số liệu theo vùng cũng có 6 cột
(***) & mỗi vùng chép đi & chép đến đều có mốc là ô nằm ở dòng thứ 2 & cột thứ 4 kế từ ô đầu của vùng.
(+) Ta gán mã cho vùng cần chép đi là bRng & vùng chép tới là aRng
(++) Tiến hành xác định khoanh vùng chép đi theo vòng lặp trên dòng 15 với bước nhảy là 6; Cứ mỗi bước nhảy ta xác định được bRng.
Trong mỗi bước lặp, ta xác định ô mốc(mà ta đã đề cập ở (***), (Giả sử trị của nó là 'Lop'
(+++) Ta cần tiến hành tìm 'Lop' này trên dòng thứ 2 của bảng A; Khi tìm thấy thì ta xác định được ô đều tiên của tiểu vùng (aRng) trên bảng A
(+4) Sau khi đã định vị được tiểu vùng rồi, chuyện chép sẽ phải 'iên ổn' thôi; Mà thô thiển nhất sẽ là 2 vòng lặp theo LK của 2 tiểu vùng (của B & A) đang xét

Khi phân tích như vậy mình cho rằng xài Dictionary là xài dao mỗ giết gà rồi!

Chúc các bạn tuần làm việc hiệu quả!


PHP:
Sub ChepTuBangBLenBangA()
Dim aRng As Range, bRng As Range, Rng As Range, sRng As Range
Dim Rws As Long, J As Long
Dim TenLop As String

Rws = [d15].CurrentRegion.Rows.Count
Set Rng = Range([A2], [ZZ2].End(xlToLeft))
For J = 4 To 99 Step 6
    If Cells(15, J).Value = "" Then
        Cells(15, J).Interior.ColorIndex = 38:            Exit For
    Else
        TenLop = Cells(16, J).Value:                        Set bRng = Cells(15, J - 3).Resize(Rws, 6)
        Set sRng = Rng.Find(TenLop, , xlFormulas, xlWhole)
        If Not sRng Is Nothing Then
            Set aRng = sRng.Offset(-1, -3).Resize(1 + Rws, 6)           
            MsgBox aRng.Address            '**    '  
        End If
    End If
Next J
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Trước mắt thì tôi thấy bài toán chỉ là giản dị xác định bảng tra và hàm Application.Match. Lấy được đúng dòng là lấy được dữ liệu.
 
Upvote 0
Mình xin phân tích bài toán của bạn như sau:
(*) Bảng B bạn đang có 2 vùng (cần chép đến bảng A); Mà trong đó mỗi vùng gồm 6 cột với số dòng như nhau (hoặc không như nhau cũng OK)
(**) Bảng A cần được chép số liệu theo vùng cũng có 6 cột
(***) & mỗi vùng chép đi & chép đến đều có mốc là ô nằm ở dòng thứ 2 & cột thứ 4 kế từ ô đầu của vùng.
(+) Ta gán mã cho vùng cần chép đi là bRng & vùng chép tới là aRng
(++) Tiến hành xác định khoanh vùng chép đi theo vòng lặp trên dòng 15 với bước nhảy là 6; Cứ mỗi bước nhảy ta xác định được bRng.
Trong mỗi bước lặp, ta xác định ô mốc(mà ta đã đề cập ở (***), (Giả sử trị của nó là 'Lop'
(+++) Ta cần tiến hành tìm 'Lop' này trên dòng thứ 2 của bảng A; Khi tìm thấy thì ta xác định được ô đều tiên của tiểu vùng (aRng) trên bảng A
(+4) Sau khi đã định vị được tiểu vùng rồi, chuyện chép sẽ phải 'iên ổn' thôi; Mà thô thiển nhất sẽ là 2 vòng lặp theo LK của 2 tiểu vùng (của B & A) đang xét

Khi phân tích như vậy mình cho rằng xài Dictionary là xài dao mỗ giết gà rồi!

Chúc các bạn tuần làm việc hiệu quả!


PHP:
Sub ChepTuBangBLenBangA()
Dim aRng As Range, bRng As Range, Rng As Range, sRng As Range
Dim Rws As Long, J As Long
Dim TenLop As String

Rws = [d15].CurrentRegion.Rows.Count
Set Rng = Range([A2], [ZZ2].End(xlToLeft))
For J = 4 To 99 Step 6
    If Cells(15, J).Value = "" Then
        Cells(15, J).Interior.ColorIndex = 38:            Exit For
    Else
        TenLop = Cells(16, J).Value:                        Set bRng = Cells(15, J - 3).Resize(Rws, 6)
        Set sRng = Rng.Find(TenLop, , xlFormulas, xlWhole)
        If Not sRng Is Nothing Then
            Set aRng = sRng.Offset(-1, -3).Resize(1 + Rws, 6)          
            MsgBox aRng.Address            '**    ' 
        End If
    End If
Next J
End Sub
Em cảm ơn bác @SA_DQ theo em hiểu ý của bác là xác định được 2 tiểu vùng aRng và bRng rồi ta sử dụng vòng lặp xác định các lỗ khoan trùng nhau rồi nhận giá trị(dùng Dic trong 2 tiểu vùng đó "Em hiểu vậy"). Do e người mới và mới học VBA nên e xin phép đọc và tìm hiểu tiếp ạ.
Bài đã được tự động gộp:

Trước mắt thì tôi thấy bài toán chỉ là giản dị xác định bảng tra và hàm Application.Match. Lấy được đúng dòng là lấy được dữ liệu.
Theo em hiểu nếu xác định dùng hàm match thì tìm kiếm bằng 2 điều kiện Lỗ khoan và Min or max phải ko ạ?.
 
Upvote 0
Em cảm ơn bác @SA_DQ theo em hiểu ý của bác là xác định được 2 tiểu vùng aRng và bRng rồi ta sử dụng vòng lặp xác định các lỗ khoan trùng nhau rồi nhận giá trị(dùng Dic trong 2 tiểu vùng đó "Em hiểu vậy"). Do e người mới và mới học VBA nên e xin phép đọc và tìm hiểu tiếp ạ.
[*] Nếu muốn nhanh hơn tẹo thì đưa các trị trong bRng vô mảng (Array())
Thiết lập vòng lặp duyệt theo cột A của aRng
Thiết lập vòng lặp trong duyệt theo mảng bRng
(*) Nếu trị trong mảng & trên aRng trùng nhau (Ở cột đầu, hiển nhiên rồi) thì chép số liệu, vậy thôi & chúc thành công!
 
Upvote 0
[*] Nếu muốn nhanh hơn tẹo thì đưa các trị trong bRng vô mảng (Array())
Thiết lập vòng lặp duyệt theo cột A của aRng
Thiết lập vòng lặp trong duyệt theo mảng bRng
(*) Nếu trị trong mảng & trên aRng trùng nhau (Ở cột đầu, hiển nhiên rồi) thì chép số liệu, vậy thôi & chúc thành công!
Mã:
Sub ChepTuBangBLenBangA()
Dim aRng As Range, bRng As Range, Rng As Range, sRng As Range
Dim itemA As Range
Dim irow As Long
Dim dic As Object
Dim dataB, dataA As Variant
Dim Rws As Long, j As Long
Dim TenLop As String
Dim c, r, k, i As Long
Rws = [D15].CurrentRegion.Rows.Count
Set Rng = Range([A2], [ZZ2].End(xlToLeft))
For j = 4 To 99 Step 6
    If Cells(15, j).Value = "" Then
        Cells(15, j).Interior.ColorIndex = 38:            Exit For
    Else
        TenLop = Cells(16, j).Value:       Set bRng = Cells(15, j - 3).Resize(Rws, 6)
        Set sRng = Rng.Find(TenLop, , xlFormulas, xlWhole)
        If Not sRng Is Nothing Then
            Set aRng = sRng.Offset(-1, -3).Resize(1 + Rws, 6)
'---------------------------------------------------------------------------------
            dataB = bRng
            dataA = aRng
        
        For i = 4 To UBound(dataA, 1)
            For k = 4 To UBound(dataB, 1)
                If CStr(dataA(i, 1)) = CStr(dataB(k, 1)) Then
                dataA(i, 5) = dataB(k, 5)
                dataA(i, 6) = dataB(k, 6)
                End If
            Next k
        Next i
        End If
    End If
Next j
'---------------------------------------------------------------------------------
            'MsgBox aRng.Address            '**    '
            'MsgBox bRng.Address
End Sub
Nhờ Bác @SA_DQ xem qua đoạn code e có bổ sung để lấy giá trị cho vào bảng A, em có dùng 2 vòng lặp và chạy điều kiện,khi chạy xong được vòng lập đầu thì các giá trị bảng B Nó ko vào bảng A của lớp đầu 4a, e ko biết tại sao nó lại ko update vào, e chạy lặp, đặt các giá trị của mảng thì e thấy đúng rồi, nhưng ko hiểu sao nó ko update từ bảng B và Bảng A. E chưa biết đc nguyên nhân tại sao?. Bác giúp e với.
 
Upvote 0
Dim dataB, dataA As Variant
Dim c, r, k, i As Long
Kiểu khai báo biến như này là tình trạng theo đọc/ học/ xem các tài liệu/ bài hướng dẫn/ video trên mạng không chuẩn. Gặp tình trạng này trên mạng rất nhiều.
Bạn nên đọc tài liệu từ Microsoft hoặc mua sách chuẩn ấy.
 
Upvote 0
Kiểu khai báo biến như này là tình trạng theo đọc/ học/ xem các tài liệu/ bài hướng dẫn/ video trên mạng không chuẩn. Gặp tình trạng này trên mạng rất nhiều.
Bạn nên đọc tài liệu từ Microsoft hoặc mua sách chuẩn ấy.
Em là học sinh mới mà bác, e sẽ học lại cách viết thế nào cho chuẩn. Mong được bác chỉ giáo nhiều ạ.
 
Upvote 0
Bạn mới làm phân nữa công việc mà bạn iêu cầu thôi;
Còn chuyện ghi từ mảng xuống trang tính bạn đã làm đâu kia chứ?

Bạn nếu quả là mới vô VBA thì mọi việc nên tường minh; Điều này có lợi cho chính bản thân bạn;
Mình lấy ví dụ:
Nên là
dataB() = bRng.Value

(*) Nếu là mình thì câu lệnh
dataA = aRng.Value mình sẽ không xài Vì có nhiều nhặng gì đâu là phải xài tới mảng thứ 2 này
 
Upvote 0
Kiểu khai báo biến như này là tình trạng theo đọc/ học/ xem các tài liệu/ bài hướng dẫn/ video trên mạng không chuẩn. Gặp tình trạng này trên mạng rất nhiều.
Bạn nên đọc tài liệu từ Microsoft hoặc mua sách chuẩn ấy.
Chẳng những vậy, nó còn là cả một quá trình cắt dán cẩu thả.
- Có nhiều biến không hề dùng vẫn được khai.
- Tên biến đặt chả theo một tình tự nào cả. Theo dõi nhiệm vụ của từng biến muốn nổ óc.
 
Upvote 0
Chẳng những vậy, nó còn là cả một quá trình cắt dán cẩu thả.
- Có nhiều biến không hề dùng vẫn được khai.
- Tên biến đặt chả theo một tình tự nào cả. Theo dõi nhiệm vụ của từng biến muốn nổ óc.
Em biết lỗi của e rồi mà bác, tại là học sinh mới, học kiểu cấp tốc, nên hơi cầu thả. ko đc học bài bản từ đầu. cảm ơn bác cho em vài đường nhắc nhở. Nhờ bác chỉ giáo e nhiều. E rút kinh nghiệm.
Bài đã được tự động gộp:

Bạn mới làm phân nữa công việc mà bạn iêu cầu thôi;
Còn chuyện ghi từ mảng xuống trang tính bạn đã làm đâu kia chứ?

Bạn nếu quả là mới vô VBA thì mọi việc nên tường minh; Điều này có lợi cho chính bản thân bạn;
Mình lấy ví dụ:
Nên là
dataB() = bRng.Value

(*) Nếu là mình thì câu lệnh
dataA = aRng.Value mình sẽ không xài Vì có nhiều nhặng gì đâu là phải xài tới mảng thứ 2 này
Mã:
Sub ChepTuBangBLenBangA()
Dim aRng As Range, bRng As Range, Rng As Range, sRng As Range
Dim dataB, dataA As Variant
Dim ArrdataA As Variant
Dim Rws As Long, j As Long
Dim TenLop As String
Dim k, i As Long

Rws = [D15].CurrentRegion.Rows.Count
Set Rng = Range([A2], [ZZ2].End(xlToLeft))

For j = 4 To 99 Step 6
    If Cells(15, j).Value = "" Then
        Cells(15, j).Interior.ColorIndex = 38:
        Exit For
    Else
        TenLop = Cells(16, j).Value
        Set bRng = Cells(15, j - 3).Resize(Rws, 6)
        Set sRng = Rng.Find(TenLop, , xlFormulas, xlWhole)
        If Not sRng Is Nothing Then
            Set aRng = sRng.Offset(-1, -3).Resize(1 + Rws, 6)
            dataB = bRng.Value
        For i = 4 To UBound(dataB, 1)
            For k = 4 To UBound(dataB, 1)
                If CStr(aRng.Cells(i, 1)) = CStr(dataB(k, 1)) Then
                aRng.Cells(i, 5).Value = dataB(k, 5)
                aRng.Cells(i, 6).Value = dataB(k, 6)
                End If
            Next k
        Next i
        End If
    End If
Next j
End Sub
Em đã chỉnh sửa code, và nó đã chạy đc, nhờ bác chỉ nói cho mấy chỗ e rút ngắn lại được, trong code chắc có nhiều chỗ khai báo biến hay sử dụng ko đc chuẩn, Do học vội vã nên đôi khi trình bày ko đc cần thận, bác thông cảm nhé mong đc học hỏi nhiều kiến thức của bác hơn.
Cuối cùng em xin cảm ơn bác, Chúc bác t4,t5,t6,t7,CN luôn vui vẻ.
 
Lần chỉnh sửa cuối:
Upvote 0
Web KT
Back
Top Bottom