Code lấy dày, rộng, dài (1 người xem)

[DMQ]

Chào các anh chị!!!!
Em có file, trong file em có code lấy dày, rộng, dài. Em có bắt chước code của các anh chị trên DD, nhưng em thấy nó dài dài sao ấy, các anh chị có thể rút gọn lại dùm em ạ.
Em cám ơn.

 

[snow25]

Chào các anh chị!!!!
Em có file, trong file em có code lấy dày, rộng, dài. Em có bắt chước code của các anh chị trên DD, nhưng em thấy nó dài dài sao ấy, các anh chị có thể rút gọn lại dùm em ạ.
Em cám ơn.

Nghiên cứu Dictionary và mảng nhé.

 

[DMQ]

Em mới bập bẹ thôi, anh giúp em với.

 

[SA_DQ]

@Tác giả bài đăng: Đoạn các lệnh trong khoản trích này nhằm mục đích gì vậy:

' . . . . . . . . .   '
        With Sheets("Rec")
            lr = .Range("A" & Rows.Count).End(xlUp).Row
            For I = 5 To lr
            Next I
            .Cells(Row, 5).Value = Description
        End With
' . . . . . . . . .   '

 

[DMQ]

nó là lấy cột Diễn giải đó thầy.

 

[SA_DQ]

Bạn thử bỏ vòng lặp trong những đoạn đó xem có bị gì không, mình cảm thấy vòng lặp đó vậy là thừa.

 

[DMQ]

Em có thử bỏ vòng lặp, không bị gì hết Thầy ơi.
Còn có cách dùng Dic như anh @snow25 nói nữa, các anh làm cho em học hỏi với.

 

[VetMini]

... em thấy nó dài dài sao ấy, các anh chị có thể rút gọn lại dùm em ạ.

Em mới bập bẹ thôi, anh giúp em với.

...
Còn có cách dùng Dic như anh @snow25 nói nữa, các anh làm cho em học hỏi với.

Thực sự thì bạn muốn học, hay muốn nhờ viết giùm code khác?

 

[DMQ]

thực là nhờ viết code khác ạ.

 

[SA_DQ]

Phải chi bạn viết Code như thế này thì sẽ thấy sự ngộ nghĩnh của mình:

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim I As Long, lR As Long, counter As Integer, UnitWeight As Integer, Col As Integer, Row As Integer
 Dim MaSo As String, Description As String
    
 If Target.Count > 1 Then Exit Sub
2 If Not Intersect(Target, Range("D5:K10000")) Is Nothing Then
    If IsEmpty(Target) Then Exit Sub
    Row = Target.Row:           Col = Target.Column
    If IsEmpty(Cells(Row, 1)) Then
        MsgBox "Ban Cân Nhâp Du Liêu Vào Côt Ngày Truóc", vbCritical
        Exit Sub
    End If
    MaSo = Cells(Row, 4):        DoDay = Cells(Row, 6)
    Rong = Cells(Row, 7):        Dai = Cells(Row, 8)
3    If Col = 4 Then            '** '
        With Sheets("Sue")
            lR = .Range("B" & Rows.Count).End(xlUp).Row
            For I = 8 To lR
                If .Range("B" & I) = MaSo Then Description = .Range("I" & I):
                Exit For
            Next I
        End With
        With Sheets("Rec")
'            lr = .Range("A" & Rows.Count).End(xlUp).Row
'            For I = 5 To lr
'            Next I
            .Cells(Row, 5).Value = Description
        End With
30      If Col = 4 Then
            With Sheets("Sue")
                lR = .Range("B" & Rows.Count).End(xlUp).Row
                For I = 8 To lR
                    If .Range("B" & I) = MaSo Then DoDay = .Range("E" & I): Exit For
                Next I
            End With
            With Sheets("Rec")
1
                .Cells(Row, 6).Value = DoDay
            End With
31        End If
40        If Col = 4 Then
            With Sheets("Sue")
                lR = .Range("B" & Rows.Count).End(xlUp).Row
                For I = 8 To lR
                    If .Range("B" & I) = MaSo Then Rong = .Range("F" & I): Exit For
                Next I
            End With
            With Sheets("Rec")
2
                .Cells(Row, 7).Value = Rong
            End With
41        End If
50        If Col = 4 Then
            With Sheets("Sue")
                lR = .Range("B" & Rows.Count).End(xlUp).Row
                For I = 8 To lR
                    If .Range("B" & I) = MaSo Then Dai = .Range("G" & I): Exit For
                Next I
            End With
            With Sheets("Rec")
3
                .Cells(Row, 8).Value = Dai
            End With
51        End If
60        If Col = 4 Then
            With Sheets("Sue")
                lR = .Range("B" & Rows.Count).End(xlUp).Row
                For I = 8 To lR
                    If .Range("B" & I) = MaSo Then UnitWeight = .Range("H" & I): Exit For
                Next I
            End With
            With Sheets("Rec")
4
                .Cells(Row, 9).Value = UnitWeight
            End With
61        End If
39    End If
 End If
End Sub

 

[DMQ]

Ý Thầy là sao em không hiểu?????

 

[snow25]

Ý Thầy là sao em không hiểu?????

Có phải bài của bạn là nó sẽ cập nhập danh mục mới mỗi,khi bạn,điền thông tin.Và chỉ cập,nhập 1 lần.Nếu đúng vậy thì đơn giản,à.

 

[SA_DQ]

Ý . . . là sao em không hiểu?????

Ý mình là mệnh đề lệnh

If Col = 4 Then

có ở khắp nơi như vậy có hợp lý hay không?
1./ Sao phải lặp lại mệnh đề này nhiều lần như vậy?
2./ Mệnh đề này đối chiếu với

If Not Intersect(Target, Range("D5:K10000")) Is Nothing Then

Thì có gì đó hơi thừa thải không cần thiết, vì phạm vi cột quá ư là nhiều so với cần thiết.

 

[DMQ]

Bởi vậy em mới nhờ rút gọn lại dùm em, thầy @SA_DQ
rút gọn dùm em với.

 

[bebo021999]

Code hiện tại có rất nhiều thừa thãi: Nếu chỉ quan tâm đến việc thay đổi giá trị cột D thì chỉ vầy là đủ:

 Private Sub Worksheet_Change(ByVal Target As Range)
Dim r&, arr()
If Target.Column <> 4 Or Target.Count > 1 Or IsEmpty(Target) Then Exit Sub
r = Target.Row
If IsEmpty(Cells(r, 1)) Then
    MsgBox "Ban can nhap du lieu vao cot Ngay truoc", vbCritical
    Exit Sub
End If
With Sheets("Sue")
    lr = .Range("B" & Rows.Count).End(xlUp).Row
    For i = 6 To lr
        If .Range("B" & i) = Target Then
            ReDim arr(1 To 1, 1 To 6)
            arr(1, 1) = Target: arr(1, 2) = .Cells(i, "I").Value
            arr(1, 3) = .Cells(i, "E").Value: arr(1, 4) = .Cells(i, "F").Value
            arr(1, 5) = .Cells(i, "G").Value: arr(1, 6) = .Cells(i, "H").Value
            Target.Resize(1, 6).Value = arr
            Exit Sub
        End If
    Next
End With
End Sub

 

[snow25]

Bởi vậy em mới nhờ rút gọn lại dùm em, thầy @SA_DQ
rút gọn dùm em với.

Sao không phải là code khác nhanh hơn.Tiện hơn mà cứ phải là rút gọn code của bạn.Nếu đúng ý của tôi nói ở bài 12 thì code khác nhanh hơn.

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

Code hiện tại có rất nhiều thừa thãi: Nếu chỉ quan tâm đến việc thay đổi giá trị cột D thì chỉ vầy là đủ:

 Private Sub Worksheet_Change(ByVal Target As Range)
Dim r&, arr()
If Target.Column <> 4 Or Target.Count > 1 Or IsEmpty(Target) Then Exit Sub
r = Target.Row
If IsEmpty(Cells(r, 1)) Then
    MsgBox "Ban can nhap du lieu vao cot Ngay truoc", vbCritical
    Exit Sub
End If
With Sheets("Sue")
    lr = .Range("B" & Rows.Count).End(xlUp).Row
    For i = 6 To lr
        If .Range("B" & i) = Target Then
            ReDim arr(1 To 1, 1 To 6)
            arr(1, 1) = Target: arr(1, 2) = .Cells(i, "I").Value
            arr(1, 3) = .Cells(i, "E").Value: arr(1, 4) = .Cells(i, "F").Value
            arr(1, 5) = .Cells(i, "G").Value: arr(1, 6) = .Cells(i, "H").Value
            Target.Resize(1, 6).Value = arr
            Exit Sub
        End If
    Next
End With
End Sub

Hình như code này chỉ là cập nhập giá trị cũ.Không có thêm mới.Đầu tiên em cứ tưởng bác sa viết hóa ra không phải.

 

[DMQ]

Sheet Rec là nhập liệu hàng ngày, sheet Sue là bảng danh mục, bạn @snow25 dùng Dic cho mình xem với

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

Cám ơn bạn @bebo021999 nhiều

 

[bebo021999]

Không cần dùng Dic.
Code này bổ sung phần kiểm tra nếu mã chưa tồn tại thì sẽ cho phép bổ sung.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r&, arr(), found As Boolean, newV, oldV
If Target.Column <> 4 Or Target.Count > 1 Or IsEmpty(Target) Then Exit Sub
r = Target.Row
If IsEmpty(Cells(r, 1)) Then
    MsgBox "Ban can nhap du lieu vao cot Ngay truoc", vbCritical
    Exit Sub
End If
With Sheets("Sue")
back:
    lr = .Range("B" & Rows.Count).End(xlUp).Row
    For i = 6 To lr
        If .Range("B" & i) = Target Then
            found = True
            ReDim arr(1 To 1, 1 To 6)
            arr(1, 1) = Target: arr(1, 2) = .Cells(i, "I").Value
            arr(1, 3) = .Cells(i, "E").Value: arr(1, 4) = .Cells(i, "F").Value
            arr(1, 5) = .Cells(i, "G").Value: arr(1, 6) = .Cells(i, "H").Value
            Target.Resize(1, 6).Value = arr
            Exit Sub
        End If
    Next
    If Not found Then
        If MsgBox("Ma so moi, ban co muon bo sung khong?", vbYesNo) = vbYes Then
            ip1 = InputBox("nhap do Day:")
            ip2 = InputBox("nhap chieu Rong:")
            ip3 = InputBox("nhap chieu Dai")
            ip4 = InputBox("nhap Trong Luong:")
            If Not IsNumeric(ip1 + ip2 + ip3 + ip4) Or ip1 < 0 Or ip2 < 0 Or ip3 < 0 Or ip4 < 0 Then
                MsgBox "Du liêu nhap sai!", vbCritical
                Exit Sub
            End If
            .Cells(lr + 1, "B").Value = Target
            .Cells(lr + 1, "E").Value = ip1
            .Cells(lr + 1, "F").Value = ip2
            .Cells(lr + 1, "G").Value = ip3
            .Cells(lr + 1, "H").Value = ip4
            .Cells(lr + 1, "I").Value = ip1 & "x" & ip2 & "x" & ip3
            GoTo back
        Else
            newV = Target.Value
            With Application
                .EnableEvents = False
                .Undo
                oldV = Target.Value
                .EnableEvents = True
            End With
            Target.Value = oldV
        End If
    End If
End With
End Sub

 

[DMQ]

Không cần tạo danh mục mới đâu bạn @bebo021999 ơi, ở sheet Rec cột tổng trọng lượng mình đang dùng công thức, bạn viết code thay công thức dùm mình được không ạ

 

[bebo021999]

Không cần tạo danh mục mới đâu bạn @bebo021999 ơi, ở sheet Rec cột tổng trọng lượng mình đang dùng công thức, bạn viết code thay công thức dùm mình được không ạ

Thêm chút xíu vào nhé:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r&, arr()
If Target.Column <> 4 Or Target.Count > 1 Or IsEmpty(Target) Then Exit Sub
r = Target.Row
If IsEmpty(Cells(r, 1)) Then
    MsgBox "Ban can nhap du lieu vao cot Ngay truoc", vbCritical
    Exit Sub
End If
With Sheets("Sue")
    lr = .Range("B" & Rows.Count).End(xlUp).Row
    For i = 6 To lr
        If .Range("B" & i) = Target Then
            ReDim arr(1 To 1, 1 To 6)
            arr(1, 1) = Target: arr(1, 2) = .Cells(i, "I").Value
            arr(1, 3) = .Cells(i, "E").Value: arr(1, 4) = .Cells(i, "F").Value
            arr(1, 5) = .Cells(i, "G").Value: arr(1, 6) = .Cells(i, "H").Value
            Target.Resize(1, 6).Value = arr
            With Sheets("Rec")
                lr = .Range("D" & Rows.Count).End(xlUp).Row
                .Range("K2:K" & lr).Formula = "=I2*J2"
            End With
            Exit Sub
        End If
    Next
End With
End Sub