Mình cần giúp code cập nhật dữ liệu khi thay đổi ô điều kiện

giaiphapexcel93@ · 17/12/21

Mọi người giúp mình viết code VBA Excel như sau: Khi chọn bất kì một ngày(VD: ngày 1/3/2021) tại ô (C3 của sheet NKTC Móng ĐZ) thì trả về kết quả : + các đầu mục công việc thực hiện hàng ngày tương ứng với giá trị ô D2 của sheet CV Móng ĐZ; các đầu mục công việc nghiệm thu ứng với giá trị ô D2 của sheet NT Móng ĐZ (chú ý phải tách ra từng hạng mục riêng biệt sau dấu phẩy trong một câu) và tất cả kết quả trả về tại sheet NKTC Móng ĐZ. Xin cám ơn mọi người!

SA_DQ · 17/12/21

PHP:

Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, [C3]) Is Nothing Then
    Dim Rng As Range, sRng As Range, Sh As Worksheet, aTmp
    Dim J As Integer, W As Byte
    
    Set Sh = Sheet1
    Set Rng = Sh.[c2].Resize(31)
    Rng.NumberFormat = "MM/DD/yyyy"
    [D17].Resize(13).Value = Space(0)
    Set sRng = Rng.Find(Target.Value, , xlFormulas, xlWhole)
    If Not sRng Is Nothing Then
        aTmp = Split(sRng.Offset(, 1).Value, ",")
        ReDim Arr(1 To 1 + UBound(aTmp), 1 To 1)
        For J = 0 To UBound(aTmp)
            Arr(J + 1, 1) = aTmp(J)
        Next J
        [D17].Resize(J).Value = Arr()
    End If
    Set Sh = Sheet4
    Set Rng = Sh.[c2].Resize(31)
    Rng.NumberFormat = "MM/DD/yyyy"
    [D32].Resize(6).Value = Space(0)
    Set sRng = Rng.Find(Target.Value, , xlFormulas, xlWhole)
    If Not sRng Is Nothing Then
        aTmp = Split(sRng.Offset(, 1).Value, ",")
        ReDim Arr(1 To 1 + UBound(aTmp), 1 To 1)
        For J = 0 To UBound(aTmp)
            Arr(J + 1, 1) = aTmp(J)
        Next J
        [D32].Resize(J).Value = Arr()
    End If
 End If
End Sub

giaiphapexcel93@ · 17/12/21

SA_DQ đã viết:

PHP:

Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, [C3]) Is Nothing Then
    Dim Rng As Range, sRng As Range, Sh As Worksheet, aTmp
    Dim J As Integer, W As Byte
   
    Set Sh = Sheet1
    Set Rng = Sh.[c2].Resize(31)
    Rng.NumberFormat = "MM/DD/yyyy"
    [D17].Resize(13).Value = Space(0)
    Set sRng = Rng.Find(Target.Value, , xlFormulas, xlWhole)
    If Not sRng Is Nothing Then
        aTmp = Split(sRng.Offset(, 1).Value, ",")
        ReDim Arr(1 To 1 + UBound(aTmp), 1 To 1)
        For J = 0 To UBound(aTmp)
            Arr(J + 1, 1) = aTmp(J)
        Next J
        [D17].Resize(J).Value = Arr()
    End If
    Set Sh = Sheet4
    Set Rng = Sh.[c2].Resize(31)
    Rng.NumberFormat = "MM/DD/yyyy"
    [D32].Resize(6).Value = Space(0)
    Set sRng = Rng.Find(Target.Value, , xlFormulas, xlWhole)
    If Not sRng Is Nothing Then
        aTmp = Split(sRng.Offset(, 1).Value, ",")
        ReDim Arr(1 To 1 + UBound(aTmp), 1 To 1)
        For J = 0 To UBound(aTmp)
            Arr(J + 1, 1) = aTmp(J)
        Next J
        [D32].Resize(J).Value = Arr()
    End If
 End If
End Sub

Cám ơn

SA_DQ đã viết:

PHP:

Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, [C3]) Is Nothing Then
    Dim Rng As Range, sRng As Range, Sh As Worksheet, aTmp
    Dim J As Integer, W As Byte
   
    Set Sh = Sheet1
    Set Rng = Sh.[c2].Resize(31)
    Rng.NumberFormat = "MM/DD/yyyy"
    [D17].Resize(13).Value = Space(0)
    Set sRng = Rng.Find(Target.Value, , xlFormulas, xlWhole)
    If Not sRng Is Nothing Then
        aTmp = Split(sRng.Offset(, 1).Value, ",")
        ReDim Arr(1 To 1 + UBound(aTmp), 1 To 1)
        For J = 0 To UBound(aTmp)
            Arr(J + 1, 1) = aTmp(J)
        Next J
        [D17].Resize(J).Value = Arr()
    End If
    Set Sh = Sheet4
    Set Rng = Sh.[c2].Resize(31)
    Rng.NumberFormat = "MM/DD/yyyy"
    [D32].Resize(6).Value = Space(0)
    Set sRng = Rng.Find(Target.Value, , xlFormulas, xlWhole)
    If Not sRng Is Nothing Then
        aTmp = Split(sRng.Offset(, 1).Value, ",")
        ReDim Arr(1 To 1 + UBound(aTmp), 1 To 1)
        For J = 0 To UBound(aTmp)
            Arr(J + 1, 1) = aTmp(J)
        Next J
        [D32].Resize(J).Value = Arr()
    End If
 End If
End Sub

Cảm ơn SA_DQ đã giúp đỡ. Nhưng khi trả về kết quả có 1 lỗi nhỏ đó là khoảng trắng đầu câu, có code VBA Excel nào để tự động xóa khoảng trắng ở kết quả (sheet NKTC Móng ĐZ) không?

SA_DQ · 17/12/21

(1) Thì bạn xài thêm hàm TRIM$() để khử các khoảng trắng đó đi, ví dụ
Arr(J + 1, 1) = Trim$(aTmp(J))

(2)

Mã:

Dim Sh As Worksheet, Rng As Range
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, [C3]) Is Nothing Then
    GPE Target:                     GPE Target, 4
 End If
End Sub

PHP:

Sub GPE(Targ As Range, Optional Num As Byte = 1)
 Dim sRng As Range
 Dim Dg As Integer, SoDg As Integer, J As Integer
 
 On Error GoTo LoiCT
 If Num = 1 Then
    Set Sh = Sheet1
 ElseIf Num = 4 Then
    Set Sh = Sheet4
 End If
 Set Rng = Sh.[c2].Resize(31)
 Rng.NumberFormat = "MM/DD/yyyy"
 Dg = Switch(Num = 1, 17, Num = 4, 32)
 SoDg = Switch(Num = 1, 13, Num = 4, 6)
 Cells(Dg, "D").Resize(SoDg).Value = Space(0)
 Set sRng = Rng.Find(Targ.Value, , xlFormulas, xlWhole)
 If Not sRng Is Nothing Then
    aTmp = Split(sRng.Offset(, 1).Value, ",")
    ReDim Arr(1 To 1 + UBound(aTmp), 1 To 1)
    For J = 0 To UBound(aTmp)
        Arr(J + 1, 1) = Trim$(aTmp(J))
    Next J
3    Cells(Dg, "D").Resize(J).Value = Arr()
 End If
Err_: Exit Sub
LoiCT:
    If Err = 9 Then
        Resume Next
    ElseIf Err = 1004 Then
        MsgBox "Nothing":               Resume Next
    Else
        GoTo Err_
    End If
End Sub

giaiphapexcel93@ · 21/12/21

SA_DQ đã viết:

(1) Thì bạn xài thêm hàm TRIM$() để khử các khoảng trắng đó đi, ví dụ
Arr(J + 1, 1) = Trim$(aTmp(J))

(2)

Mã:

Dim Sh As Worksheet, Rng As Range
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, [C3]) Is Nothing Then
    GPE Target:                     GPE Target, 4
 End If
End Sub

PHP:

Sub GPE(Targ As Range, Optional Num As Byte = 1)
 Dim sRng As Range
 Dim Dg As Integer, SoDg As Integer, J As Integer
 
 On Error GoTo LoiCT
 If Num = 1 Then
    Set Sh = Sheet1
 ElseIf Num = 4 Then
    Set Sh = Sheet4
 End If
 Set Rng = Sh.[c2].Resize(31)
 Rng.NumberFormat = "MM/DD/yyyy"
 Dg = Switch(Num = 1, 17, Num = 4, 32)
 SoDg = Switch(Num = 1, 13, Num = 4, 6)
 Cells(Dg, "D").Resize(SoDg).Value = Space(0)
 Set sRng = Rng.Find(Targ.Value, , xlFormulas, xlWhole)
 If Not sRng Is Nothing Then
    aTmp = Split(sRng.Offset(, 1).Value, ",")
    ReDim Arr(1 To 1 + UBound(aTmp), 1 To 1)
    For J = 0 To UBound(aTmp)
        Arr(J + 1, 1) = Trim$(aTmp(J))
    Next J
3    Cells(Dg, "D").Resize(J).Value = Arr()
 End If
Err_: Exit Sub
LoiCT:
    If Err = 9 Then
        Resume Next
    ElseIf Err = 1004 Then
        MsgBox "Nothing":               Resume Next
    Else
        GoTo Err_
    End If
End Sub

Cám ơn bạn nhé. Bạn giúp mình code VBA Excel đưa thông tin (Thời tiết trong ngày, Thiết bị nhân công, Nhân lực) ở sheet CV Móng ĐZ sang sheet NKTC Móng ĐZ tương ứng với thời gian theo danh sách xổ xuống được không àh.

SA_DQ · 21/12/21

Mình chỉ giúp 1/3 công việc thôi, nhường bạn phần còn lại; & nhớ bỏ trộn ô khi bị lỗi:

PHP:

' . . . . '
    Set Sh = Sheet1
    Set Rng = Sh.[c3].Resize(31)
    Rng.NumberFormat = "DD/MM/yyyy"
    [D17].Resize(13).Value = Space(0)
    
    Set sRng = Rng.Find(Target.Value, , xlFormulas, xlWhole)
    If Not sRng Is Nothing Then
        aTmp = Split(sRng.Offset(, 1).Value, ",")
        ReDim Arr(1 To 1 + UBound(aTmp), 1 To 1)
        For J = 0 To UBound(aTmp)
            Arr(J + 1, 1) = aTmp(J)
        Next J
        [D17].Resize(J).Value = Arr()
'Chép Thòi Tiêt & Thiêt Bi, Nhân Luc:       '
        [M4].Value = sRng.Offset(, 2).Value
        [V4].Value = sRng.Offset(, 3).Value
        [AD4].Value = sRng.Offset(, 4).Value
        sRng.Offset(, 5).Resize(, 9).Copy
        Range("S5").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=True
'       . . . . .         '
    End If
'  . . . . . . . .        '

Mình cần giúp code cập nhật dữ liệu khi thay đổi ô điều kiện

giaiphapexcel93@

Thành viên mới

File đính kèm

SA_DQ

/(hông là gì!

giaiphapexcel93@

Thành viên mới

File đính kèm

SA_DQ

/(hông là gì!

giaiphapexcel93@

Thành viên mới

File đính kèm

SA_DQ

/(hông là gì!

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

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