Xin code tự chèn dòng khi thêm mã (1 người xem)

  • Thread starter Thread starter LYSM
  • Ngày gửi Ngày gửi
Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
L

LYSM

Thành viên thường trực
Tham gia
16/3/11
Bài viết
290
Được thích
26
Em chào các thầy cô, anh chị!
Em muốn chèn dòng khi thêm mã như file đính kèm, nhờ các thầycô và anh chị giúp đỡ em. Cũng có nhiều chủ đề về tự động chèn dòng nhưng emchưa thấy giống yêu cầu của em, mong mọi người giúp đỡ. Em cảm ơn nhiều!
PS: Thêm 1 ý nữa là khi em xóa đi 1 mã nào đó thì bảng cũng tự độngxóa các dữ liệu liên quan đến mã đó
Chúc các thầy cô, anh chị có kỳ nghỉ lễ vui vẻ!
 

File đính kèm

Lần chỉnh sửa cuối:
Sắp xếp theo thời gian sắp xếp theo bầu chọn
HieuCD đã viết:
bạn chạy thử code
Mã: 
Sub InsertMa()
Dim DLarr, TenDLarr, SParr, CKarr, DSParr, Arr
Dim i, j As Long, Rws As Long, Tem As String, Dic As Object
With Sheets("Bang ma")
    DLarr = .Range("A5:A" & .Range("A5").End(xlDown).Row)
    TenDLarr = .Range("B5:B" & .Range("A5").End(xlDown).Row)
    SParr = .Range("D5:D" & .Range("D5").End(xlDown).Row)
    DSParr = .Range("E5:E" & .Range("E5").End(xlDown).Row)
End With
ReDim Arr(1 To UBound(DLarr) * UBound(SParr), 1 To 20)
Application.ScreenUpdating = False
Sheets("Che do CK").Select
[COLOR=#ff0000]ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1[/COLOR]
CKarr = Range("A5:T" & Range("A5").End(xlDown).Row).Formula
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(CKarr)
    Tem = CKarr(i, 1) & "#" & CKarr(i, 3)
    If Not Dic.exists(Tem) Then Dic.Add Tem, i
Next i
For i = 1 To UBound(Arr)
    Arr(i, 1) = DLarr(Int((i - 1) / UBound(SParr)) + 1, 1)
    Arr(i, 2) = TenDLarr(Int((i - 1) / UBound(SParr)) + 1, 1)
    Arr(i, 3) = SParr(((i - 1) Mod UBound(SParr)) + 1, 1)
    Arr(i, 4) = DSParr(((i - 1) Mod UBound(SParr)) + 1, 1)
    Tem = Arr(i, 1) & "#" & Arr(i, 3)
    Rws = Dic.Item(Tem)
    If Rws > 0 Then
    For j = 1 To 16
        Arr(i, j + 4) = CKarr(Rws, j + 4)
    Next j
    End If
Next i
Set Dic = Nothing
Range("A5:T" & Range("A5").End(xlDown).Row).Clear
ActiveSheet.ListObjects("Table1").Resize Range("A4").Resize(UBound(Arr) + 1, 5)
Range("A5").Resize(UBound(Arr), 20) = Arr
Range("A4").Resize(UBound(Arr) + 1, 20).Borders.LineStyle = xlContinuous
Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Không được bác ơi, code này vẫn giống code trước mà, cứ quên không xóa lọc là mất dữ lieu.
PS: Em sửa được rồi bác ạ, chèn dòng màu đỏ vào là ok
 
Lần chỉnh sửa cuối:
Upvote 0
Bác @HieuCD ơi, nhờ bác xem giúp em đoạn sub "TINH" với, khi em để activesheet là "Che do CK" (bấm nút caculate bên sheet "Che do CK") thì bên sheet "Data input" cho kết quả đúng, nhưng nếu activesheet là Data input (Bấm nút "Caculate" bên sheet "Data input") thì sheet "Data input" chỉ cho ra kết quả đến dòng 48 thôi. Em thấy sheet che do Ck nhiều dữ liệu hơn thì nó tính đúng nhưng nếu trường hợp ít dữ liệu hơn data input thì lại thành sai. Em cám ơn bác nhiều!
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
LYSM đã viết:
Bác @HieuCD ơi, nhờ bác xem giúp em đoạn sub "TINH" với, khi em để activesheet là "Che do CK" (bấm nút caculate bên sheet "Che do CK") thì bên sheet "Data input" cho kết quả đúng, nhưng nếu activesheet là Data input (Bấm nút "Caculate" bên sheet "Data input") thì sheet "Data input" chỉ cho ra kết quả đến dòng 48 thôi. Em thấy sheet che do Ck nhiều dữ liệu hơn thì nó tính đúng nhưng nếu trường hợp ít dữ liệu hơn data input thì lại thành sai. Em cám ơn bác nhiều!
Nhấp chuột vào đây để mở rộng...
code sót nhiều chổ, bạn sửa lại
Mã: 
Sub TINH()
Soluong
Dim DTinput(), CKarr(), Arr()
Dim i, j As Long, Rws As Long, Tem As String, Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("Che do CK")
    CKarr = .Range("A4:T" & .Range("A4").End(xlDown).Row).Value
    For i = 1 To UBound(CKarr)
      Tem = CKarr(i, 1) & "#" & CKarr(i, 3)
      If Not Dic.exists(Tem) Then Dic.Add Tem, i
    Next i
End With
Application.ScreenUpdating = False
With Sheets("Data input")
DTinput = .Range("A5:D" & .Range("A5").End(xlDown).Row).Value
ReDim Arr(1 To UBound(DTinput), 1 To 15)
For i = 1 To UBound(DTinput)
  Tem = DTinput(i, 1) & "#" & DTinput(i, 2)
  If Dic.exists(Tem) Then
    Rws = Dic.Item(Tem)
    If Rws > 0 Then
      For j = 1 To 15
        If Right(CKarr(1, j + 5), 2) = "kg" Then
          Arr(i, j) = CKarr(Rws, j + 5) * DTinput(i, 3)
        Else
          Arr(i, j) = CKarr(Rws, j + 5) * DTinput(i, 4)
        End If
      Next j
    End If
  End If
Next i
Set Dic = Nothing
.Range("H5:V" & Range("H5").End(xlDown).Row).ClearContents
.Range("H5").Resize(UBound(Arr), 15) = Arr
.ListObjects("Table2").Resize .Range("A4:V" & Range("A5").End(xlDown).Row)
End With
Application.ScreenUpdating = True
End Sub

Sub Soluong()
Dim DTinput(), CKarr(), Arr()
Dim i, j As Long, Rws As Long, Tem As String, Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("Data input")
    DTinput = .Range("A5:D" & .Range("A5").End(xlDown).Row).Value
    For i = 1 To UBound(DTinput)
    Tem = DTinput(i, 1) & "#" & DTinput(i, 2)
    If Not Dic.exists(Tem) Then Dic.Add Tem, i
Next i
End With
Application.ScreenUpdating = False
With Sheets("Che do CK")
CKarr = .Range("A5:C" & .Range("A5").End(xlDown).Row).Value
ReDim Arr(1 To UBound(CKarr), 1 To 1)
For i = 1 To UBound(CKarr)
    Tem = CKarr(i, 1) & "#" & CKarr(i, 3)
    If Dic.exists(Tem) Then
    Rws = Dic.Item(Tem)
        If Rws > 0 Then
            Arr(i, 1) = DTinput(Rws, 3)
        End If
    End If
Next i
Set Dic = Nothing
.Range(.[E5], .[E65000].End(xlUp)).ClearContents
'.Range("C5:D" & Range("A5").End(xlDown).Row).ClearContents
.Range("E5").Resize(UBound(Arr), 1) = Arr
End With
Application.ScreenUpdating = True
End Sub
nếu 2 sub không có chạy riêng thì bạn bỏ luôn 2 sub trên, và dùng 1 sub sau (đã nhập 2 thành 1)
Mã: 
Sub SL_CK()
Dim DTinput(), CKarr(), Arr()
Dim i, j As Long, Rws As Long, Tem As String, DicSL As Object, DicCK As Object
Set DicSL = CreateObject("Scripting.Dictionary")
Set DicCK = CreateObject("Scripting.Dictionary")
With Sheets("Data input")
    DTinput = .Range("A5:D" & .Range("A5").End(xlDown).Row).Value
    For i = 1 To UBound(DTinput)
    Tem = DTinput(i, 1) & "#" & DTinput(i, 2)
    If Not DicSL.exists(Tem) Then DicSL.Add Tem, i
Next i
End With
Application.ScreenUpdating = False


With Sheets("Che do CK")
CKarr = .Range("A4:T" & .Range("A4").End(xlDown).Row).Value
ReDim Arr(1 To UBound(CKarr), 1 To 1)
For i = 1 To UBound(CKarr)
    Tem = CKarr(i, 1) & "#" & CKarr(i, 3)
    If Not DicCK.exists(Tem) Then DicCK.Add Tem, i
    
    If DicSL.exists(Tem) Then
    Rws = DicSL.Item(Tem)
        If Rws > 0 Then
            Arr(i, 1) = DTinput(Rws, 3)
        End If
    End If
Next i
Set DicSL = Nothing
.Range(.[E5], .[E65000].End(xlUp)).ClearContents
.Range("E4").Resize(UBound(Arr), 1) = Arr
End With


With Sheets("Data input")
ReDim Arr(1 To UBound(DTinput), 1 To 15)
For i = 1 To UBound(DTinput)
  Tem = DTinput(i, 1) & "#" & DTinput(i, 2)
  If DicCK.exists(Tem) Then
    Rws = DicCK.Item(Tem)
    If Rws > 0 Then
      For j = 1 To 15
        If Right(CKarr(1, j + 5), 2) = "kg" Then
          Arr(i, j) = CKarr(Rws, j + 5) * DTinput(i, 3)
        Else
          Arr(i, j) = CKarr(Rws, j + 5) * DTinput(i, 4)
        End If
      Next j
    End If
  End If
Next i
Set DicCK = Nothing
.Range("H5:V" & Range("H5").End(xlDown).Row).ClearContents
.Range("H5").Resize(UBound(Arr), 15) = Arr
.ListObjects("Table2").Resize .Range("A4:V" & Range("A5").End(xlDown).Row)
End With
Application.ScreenUpdating = True
End Sub
 
Upvote 0
HieuCD đã viết:
code sót nhiều chổ, bạn sửa lại
Mã: 
Sub TINH()
Soluong
Dim DTinput(), CKarr(), Arr()
Dim i, j As Long, Rws As Long, Tem As String, Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("Che do CK")
    CKarr = .Range("A4:T" & .Range("A4").End(xlDown).Row).Value
    For i = 1 To UBound(CKarr)
      Tem = CKarr(i, 1) & "#" & CKarr(i, 3)
      If Not Dic.exists(Tem) Then Dic.Add Tem, i
    Next i
End With
Application.ScreenUpdating = False
With Sheets("Data input")
DTinput = .Range("A5:D" & .Range("A5").End(xlDown).Row).Value
ReDim Arr(1 To UBound(DTinput), 1 To 15)
For i = 1 To UBound(DTinput)
  Tem = DTinput(i, 1) & "#" & DTinput(i, 2)
  If Dic.exists(Tem) Then
    Rws = Dic.Item(Tem)
    If Rws > 0 Then
      For j = 1 To 15
        If Right(CKarr(1, j + 5), 2) = "kg" Then
          Arr(i, j) = CKarr(Rws, j + 5) * DTinput(i, 3)
        Else
          Arr(i, j) = CKarr(Rws, j + 5) * DTinput(i, 4)
        End If
      Next j
    End If
  End If
Next i
Set Dic = Nothing
.Range("H5:V" & Range("H5").End(xlDown).Row).ClearContents
.Range("H5").Resize(UBound(Arr), 15) = Arr
.ListObjects("Table2").Resize .Range("A4:V" & Range("A5").End(xlDown).Row)
End With
Application.ScreenUpdating = True
End Sub

Sub Soluong()
Dim DTinput(), CKarr(), Arr()
Dim i, j As Long, Rws As Long, Tem As String, Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("Data input")
    DTinput = .Range("A5:D" & .Range("A5").End(xlDown).Row).Value
    For i = 1 To UBound(DTinput)
    Tem = DTinput(i, 1) & "#" & DTinput(i, 2)
    If Not Dic.exists(Tem) Then Dic.Add Tem, i
Next i
End With
Application.ScreenUpdating = False
With Sheets("Che do CK")
CKarr = .Range("A5:C" & .Range("A5").End(xlDown).Row).Value
ReDim Arr(1 To UBound(CKarr), 1 To 1)
For i = 1 To UBound(CKarr)
    Tem = CKarr(i, 1) & "#" & CKarr(i, 3)
    If Dic.exists(Tem) Then
    Rws = Dic.Item(Tem)
        If Rws > 0 Then
            Arr(i, 1) = DTinput(Rws, 3)
        End If
    End If
Next i
Set Dic = Nothing
.Range(.[E5], .[E65000].End(xlUp)).ClearContents
'.Range("C5:D" & Range("A5").End(xlDown).Row).ClearContents
.Range("E5").Resize(UBound(Arr), 1) = Arr
End With
Application.ScreenUpdating = True
End Sub
nếu 2 sub không có chạy riêng thì bạn bỏ luôn 2 sub trên, và dùng 1 sub sau (đã nhập 2 thành 1)
Mã: 
Sub SL_CK()
Dim DTinput(), CKarr(), Arr()
Dim i, j As Long, Rws As Long, Tem As String, DicSL As Object, DicCK As Object
Set DicSL = CreateObject("Scripting.Dictionary")
Set DicCK = CreateObject("Scripting.Dictionary")
With Sheets("Data input")
    DTinput = .Range("A5:D" & .Range("A5").End(xlDown).Row).Value
    For i = 1 To UBound(DTinput)
    Tem = DTinput(i, 1) & "#" & DTinput(i, 2)
    If Not DicSL.exists(Tem) Then DicSL.Add Tem, i
Next i
End With
Application.ScreenUpdating = False


With Sheets("Che do CK")
CKarr = .Range("A4:T" & .Range("A4").End(xlDown).Row).Value
ReDim Arr(1 To UBound(CKarr), 1 To 1)
For i = 1 To UBound(CKarr)
    Tem = CKarr(i, 1) & "#" & CKarr(i, 3)
    If Not DicCK.exists(Tem) Then DicCK.Add Tem, i
    
    If DicSL.exists(Tem) Then
    Rws = DicSL.Item(Tem)
        If Rws > 0 Then
            Arr(i, 1) = DTinput(Rws, 3)
        End If
    End If
Next i
Set DicSL = Nothing
.Range(.[E5], .[E65000].End(xlUp)).ClearContents
.Range("E4").Resize(UBound(Arr), 1) = Arr
End With


With Sheets("Data input")
ReDim Arr(1 To UBound(DTinput), 1 To 15)
For i = 1 To UBound(DTinput)
  Tem = DTinput(i, 1) & "#" & DTinput(i, 2)
  If DicCK.exists(Tem) Then
    Rws = DicCK.Item(Tem)
    If Rws > 0 Then
      For j = 1 To 15
        If Right(CKarr(1, j + 5), 2) = "kg" Then
          Arr(i, j) = CKarr(Rws, j + 5) * DTinput(i, 3)
        Else
          Arr(i, j) = CKarr(Rws, j + 5) * DTinput(i, 4)
        End If
      Next j
    End If
  End If
Next i
Set DicCK = Nothing
.Range("H5:V" & Range("H5").End(xlDown).Row).ClearContents
.Range("H5").Resize(UBound(Arr), 15) = Arr
.ListObjects("Table2").Resize .Range("A4:V" & Range("A5").End(xlDown).Row)
End With
Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Vâng, cám ơn bác, e cũng tập toẹ nên code còn thiếu nhiều, mỗi lúc học 1 ít thôi ạ, em chưa hiểu tại sao phải thêm dấu # vào chuỗi Tem, bác giải thích giúp e được không ạ?
 
Upvote 0
LYSM đã viết:
Vâng, cám ơn bác, e cũng tập toẹ nên code còn thiếu nhiều, mỗi lúc học 1 ít thôi ạ, em chưa hiểu tại sao phải thêm dấu # vào chuỗi Tem, bác giải thích giúp e được không ạ?
Nhấp chuột vào đây để mở rộng...
thêm "#" là ký tự ít dùng để ngăn cách 2 mã nhằm đề phòng trường hợp có 2 nhóm mã khác nhau nhưng khi ghép lại thì giống nhau
ví dụ: nhóm 1 gồm 2 mã:15689 và 254, nhóm 2 gồm 2 mã là 1568 và 9254 khác nhau hoàn tòan, nhưng khi ghép lại cả 2 nhóm lại giống nhau:15689254
nên khi ghép phải có ký tự ít khi dùng chặn giửa: 15689#254, và 1568#9254 khác nhau
 
Upvote 0
Rất tiếc mất nút Cảm ơn.
Khi đọc bài này tôi cảm mến và xin có lời cảm ơn bạn HieuCD vì sự nhiệt thành của bạn khi giúp đỡ người khác; Dù trong hoàn cảnh nào cũng không một lời ca thán, Rất tận tình, rất chu đáo, chỉ bảo tận tình
 
Upvote 0
le_vis đã viết:
Rất tiếc mất nút Cảm ơn.
Khi đọc bài này tôi cảm mến và xin có lời cảm ơn bạn HieuCD vì sự nhiệt thành của bạn khi giúp đỡ người khác; Dù trong hoàn cảnh nào cũng không một lời ca thán, Rất tận tình, rất chu đáo, chỉ bảo tận tình
Nhấp chuột vào đây để mở rộng...
cám ơn bạn, mình cũng như các thành viên khác trên diễn đàn, đều có tâm huyết góp kiến thức và kinh nghiệm tích lũy cho cộng đồng Excel Việt Nam. các bạn vui khi nhận hổ trợ từ GPE hoặc biết thêm kiến thức mới, là mình vui rồi
 
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

A
  • Question Question
Nhờ anh chị em chú bác giúp em viết code vba thay cho công thức dò tìm và tính (3 người xem)
Trả lời
2
Đọc
49
A HOANG 620
A
ongke0711
  • Question Question
Trộn dữ liệu từ Excel sang Word mở rộng (phiên bản ongke0711) (2 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
12 13 14
Trả lời
262
Đọc
28K
toptikibeauty
T
T
tìm ra số tháng mà lượng hàng nhập ban đầu sử dụng hết
    • Cười
Trả lời
3
Đọc
123
minhminh27
minhminh27
nttrung_proneu
Cách giữ công thức khi lọc và tách file
Trả lời
2
Đọc
56
nttrung_proneu
nttrung_proneu
K
  • Question Question
Code vba đọc QR code file hình ảnh trên CCCD (3 người xem)
    • Cười
Trả lời
0
Đọc
47
kingbo.camera
K
Nguyễn Duy Tuân
Phiên bản mới Add-in A-Tools v10 (2024) (1 người xem)
    • Thích
2 3
Trả lời
42
Đọc
3K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
SA_DQ
[Xin hỏi] Cách tính số tiền bình quân của tài khoản trong 1 tháng
Trả lời
9
Đọc
150
ptm0412
ptm0412
H
  • Question Question
Gửi mail hàng loạt với mỗi mail là 1 file PDF đính kèm khác nhau (1 người xem)
Trả lời
1
Đọc
52
minhminh27
minhminh27
B
Làm sao đổi đơn vị B, M này sang hàng đơn vị vậy mọi người? (1 người xem)
    • Cười
Trả lời
4
Đọc
61
Bao Nguyen 89
B
C
Tạo hyperlink hàng loạt
Trả lời
9
Đọc
5K
online.tanphat
O
TrungChinhs
  • Question Question
Hỏi cách làm tròn số trong VBA
Trả lời
9
Đọc
7K
SA_DQ
SA_DQ
dongbhhg
Tìm lương cơ sở theo từng tháng
Trả lời
3
Đọc
86
dongbhhg
dongbhhg
V
Làm mẫu giấy đi đường (công lệnh) bằng Excel
Trả lời
12
Đọc
11K
Gà Công Nghệ
Gà Công Nghệ
N
Thử lập trình XLL add-in bằng C/C++ (1 người xem)
    • Thích
Trả lời
0
Đọc
83
nguyendang95
N
Tuấn Bụng Bự
tạo QRcode chuyển khoản ngân hàng
Trả lời
5
Đọc
215
Tuấn Bụng Bự
Tuấn Bụng Bự
M
Tự chèn dòng khi cập nhật dữ liệu từ trang tính khác.
Trả lời
1
Đọc
54
BuiQuangThuan
B
Quách Ngọc
Trả về kết quả ngày tháng hay khoảng trống
Trả lời
3
Đọc
63
Quách Ngọc
Quách Ngọc
MaxanB
Cần hỗ trợ công thức Vlookup nhiều sheet theo điều kiên
Trả lời
2
Đọc
87
MaxanB
MaxanB
N
Không chạy được file VBA
Trả lời
3
Đọc
147
nhjngj
N
N
Xin giúp e cách lọc dữ liệu bị trùng
Trả lời
1
Đọc
71
hoangtuaotrang_hp_vn
H
Xem thêm…

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

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
TALKSHOW KHÁM PHÁ SỨC MẠNH HÀM FILTER TRONG EXCEL 365
Back
Top Bottom