Code lấy dày, rộng, dài

Liên hệ QC
DMQ

DMQ

Thành viên dốt
Tham gia
21/3/12
Bài viết
703
Được thích
53
Giới tính
Nam
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.
 

File đính kèm

  • Hoi.xlsm
    22.4 KB · Đọc: 20
Sắp xếp theo thời gian sắp xếp theo bầu chọn
DMQ đã viết:
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.
Nhấp chuột vào đây để mở rộng...
Nghiên cứu Dictionary và mảng nhé.
 
Upvote 0
Em mới bập bẹ thôi, anh giúp em với.
 
Upvote 0
@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:
PHP: 
' . . . . . . . . .   '
        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
' . . . . . . . . .   '
 
Upvote 0
nó là lấy cột Diễn giải đó thầy.
 
Upvote 0
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.
 
Upvote 0
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.
 
Upvote 0
DMQ đã viết:
... 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 ạ.
Nhấp chuột vào đây để mở rộng...
DMQ đã viết:
Em mới bập bẹ thôi, anh giúp em với.
Nhấp chuột vào đây để mở rộng...
DMQ đã viết:
...
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.
Nhấp chuột vào đây để mở rộng...
Thực sự thì bạn muốn học, hay muốn nhờ viết giùm code khác?
 
Upvote 0
thực là nhờ viết code khác ạ.
 
Upvote 0
Phải chi bạn viết Code như thế này thì sẽ thấy sự ngộ nghĩnh của mình:

PHP: 
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
 
Upvote 0
Ý Thầy là sao em không hiểu?????
 
Upvote 0
DMQ đã viết:
Ý . . . là sao em không hiểu?????
Nhấp chuột vào đây để mở rộng...
Ý mình là mệnh đề lệnh
Mã: 
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
PHP: 
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.
 
Upvote 0
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.
 
Upvote 0
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à đủ:
PHP: 
 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
 

File đính kèm

  • Hoi.xlsm
    20.9 KB · Đọc: 7
Upvote 0
DMQ đã viết:
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.
Nhấp chuột vào đây để mở rộng...
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:

bebo021999 đã viết:
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à đủ:
PHP: 
 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
Nhấp chuột vào đây để mở rộng...
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.
 
Lần chỉnh sửa cuối:
Upvote 0
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:

Cám ơn bạn @bebo021999 nhiều
 
Upvote 0
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.
PHP: 
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
 

File đính kèm

  • Hoi.xlsm
    23.3 KB · Đọc: 4
Upvote 0
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 ạ
 
Upvote 0
DMQ đã viết:
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 ạ
Nhấp chuột vào đây để mở rộng...
Thêm chút xíu vào nhé:

PHP: 
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
 
  • Thích
Reactions: DMQ
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

T
[Giúp đỡ] Tìm số lượng nhân viên đã tham gia làm lô hàng
Trả lời
5
Đọc
74
Hoàng Tuấn 868
H
8
Hàm thống kê số lượng thành viên câu lạc bộ theo từng đợt tuyển thành viên
Trả lời
3
Đọc
71
HieuCD
H
LuuAnh980
Sao Filter của Excel kỳ lạ.
Trả lời
9
Đọc
58
Hoàng Tuấn 868
H
H
  • Question
nhờ các bác viết mẫu cho em lệnh dùng checkbox để rút ngắn thời gian thao tác
Trả lời
10
Đọc
191
hiv174
H
hoang.buivan93
Gặp rắc rối về phần công thức hàm tìm kiếm dữ liệu. Nhờ mọi người chỉ giáo giúp ạ.
Trả lời
3
Đọc
59
VetMini
V
Xem thêm…

Facebook

Giaiphapexcel.com

Group

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

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