Xin code tự chèn dòng khi thêm mã (2 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
LYSM đã viết:
File này thì chuẩn rồi bác ạ, có điều khi em đưa danh sách 250 đại lý và 50 sản phẩm mà chạy là nó đứng hình luôn. Em dùng excel 2013, nếu là excel 2010 thì chậm nhưng vẫn ra kết quả. Có cách nào cải thiện được tốc độ của nó không bác? Em cám ơn bác nhiều.
Nhấp chuột vào đây để mở rộng...
Bạn dùng code mới xem sao
Mã: 
Sub InsertMa()
Dim DLarr, SParr, CKarr, Arr
Dim i, j As Long
DLarr = Range("A5:A" & Range("A5").End(xlDown).Row)
SParr = Range("B5:B" & Range("B5").End(xlDown).Row)
ReDim Arr(1 To UBound(DLarr) * UBound(SParr), 1 To 5)
Application.ScreenUpdating = False
Sheets(2).Select
CKarr = Range("A4:E" & Range("A4").End(xlDown).Row).Formula
For i = 1 To UBound(Arr)
    Arr(i, 1) = DLarr(Int((i - 1) / UBound(SParr)) + 1, 1)
    Arr(i, 2) = SParr(((i - 1) Mod UBound(SParr)) + 1, 1)
    For j = 1 To UBound(CKarr)
        If Arr(i, 1) = CKarr(j, 1) And Arr(i, 2) = CKarr(j, 2) Then
            Arr(i, 3) = CKarr(j, 3)
            Arr(i, 4) = CKarr(j, 4)
            Arr(i, 5) = CKarr(j, 5)
        End If
    Next j
Next i
Range("A5:E" & Range("A4").End(xlDown).Row).Clear
Range("A4").Resize(UBound(Arr), 5) = Arr
ActiveSheet.ListObjects("Table1").Resize Range("A3:B" & Range("A3").End(xlDown).Row)
Range("A3").Resize(UBound(Arr) + 1, 5).Borders.LineStyle = xlContinuous
Application.ScreenUpdating = True
End Sub
 
Upvote 0
LYSM đã viết:
Hiện tại bên em vẫn đang làm thủ công như thế nên rất mất thờigian và còn bị nhầm nữa, tháng vừa rồi bị nhầm mất mấy chục triệu , may mà pháthiện kịp thời.
Nhấp chuột vào đây để mở rộng...

Trời, doanh nghiệp 250 đại lý, 80 sản phẩm mà dùng Excel để quản lý. Tiết kiệm kiểu này thì mất tiền chả có gì là lạ.
 
Upvote 0
doveandrose đã viết:
xin anh cho cái đề nghị ta nên dùng cái gì để quản lý cái sòng này ạ ? ;;;;;;;;;;;;;;;;;;;;;;
Nhấp chuột vào đây để mở rộng...

Dùng tiền chứ dùng cái gì. Cỡ tầm quy mô như thế này thì phải mướn chuyên viên chứ hỏi từng bước trên mạng thì cho đến ngày quản lý được chắc đã thất thu hàng trăm triệu.
 
Upvote 0
VetMini đã viết:
Dùng tiền chứ dùng cái gì. Cỡ tầm quy mô như thế này thì phải mướn chuyên viên chứ hỏi từng bước trên mạng thì cho đến ngày quản lý được chắc đã thất thu hàng trăm triệu.
Nhấp chuột vào đây để mở rộng...
nhờ vậy mà mình có điều kiện luyện code, tới hôm nay mới mò ra được vụ .Formular
còn vụ Table tự động điền công thức thì chịu thua, các bạn có cách nào xử giúp mình
 
Lần chỉnh sửa cuối:
Upvote 0
VetMini đã viết:
Trời, doanh nghiệp 250 đại lý, 80 sản phẩm mà dùng Excel để quản lý. Tiết kiệm kiểu này thì mất tiền chả có gì là lạ.
Nhấp chuột vào đây để mở rộng...

Tìm hết phần mềm rồi bạn, nhưng nó không đáp ứng được các điều kiện cụ thể đặc biệt là tính mở. Đến như công ty mình đang làm có cả ERP mua 100 tr $ mà vẫn phải dùng kết hợp cả excel chứ chưa nói mấy phần mềm khác. Mà có như bạn nói thuê chuyên gia thì họ cũng phải dùng 1 phần mềm nào đó chứ họ có tính nhẩm được đâu. Tiện đây xin bạn giới thiệu giúp mình một vài phần mềm có thể thay thế đc excel.
 
Lần chỉnh sửa cuối:
Upvote 0
HieuCD đã viết:
Bạn dùng code mới xem sao
Mã: 
Sub InsertMa()
Dim DLarr, SParr, CKarr, Arr
Dim i, j As Long
DLarr = Range("A5:A" & Range("A5").End(xlDown).Row)
SParr = Range("B5:B" & Range("B5").End(xlDown).Row)
ReDim Arr(1 To UBound(DLarr) * UBound(SParr), 1 To 5)
Application.ScreenUpdating = False
Sheets(2).Select
CKarr = Range("A4:E" & Range("A4").End(xlDown).Row).Formula
For i = 1 To UBound(Arr)
    Arr(i, 1) = DLarr(Int((i - 1) / UBound(SParr)) + 1, 1)
    Arr(i, 2) = SParr(((i - 1) Mod UBound(SParr)) + 1, 1)
    For j = 1 To UBound(CKarr)
        If Arr(i, 1) = CKarr(j, 1) And Arr(i, 2) = CKarr(j, 2) Then
            Arr(i, 3) = CKarr(j, 3)
            Arr(i, 4) = CKarr(j, 4)
            Arr(i, 5) = CKarr(j, 5)
        End If
    Next j
Next i
Range("A5:E" & Range("A4").End(xlDown).Row).Clear
Range("A4").Resize(UBound(Arr), 5) = Arr
ActiveSheet.ListObjects("Table1").Resize Range("A3:B" & Range("A3").End(xlDown).Row)
Range("A3").Resize(UBound(Arr) + 1, 5).Borders.LineStyle = xlContinuous
Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Em cảm ơn bác đã không ngại bỏ thời gian ra giúp em, cũngkhông thấy có cải thiện mấy bác ạ. Chắc tại dữ liệu nhiều nên 2 vòng lặp i,jgây ra. Chắc phải chấp nhận thôi.
 
Upvote 0
LYSM đã viết:
Em cảm ơn bác đã không ngại bỏ thời gian ra giúp em, cũngkhông thấy có cải thiện mấy bác ạ. Chắc tại dữ liệu nhiều nên 2 vòng lặp i,jgây ra. Chắc phải chấp nhận thôi.
Nhấp chuột vào đây để mở rộng...
bạn chạy thử code mới, nhanh hơn nhiều
Mã: 
Sub InsertMa()
Dim DLarr, SParr, CKarr, Arr
Dim i, Rws As Long, Tem As String, Dic As Object
DLarr = Range("A5:A" & Range("A5").End(xlDown).Row)
SParr = Range("B5:B" & Range("B5").End(xlDown).Row)
ReDim Arr(1 To UBound(DLarr) * UBound(SParr), 1 To 5)
Application.ScreenUpdating = False
Sheets(2).Select
CKarr = Range("A4:E" & Range("A4").End(xlDown).Row).Formula
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(CKarr)
    Tem = CKarr(i, 1) & "!@#$" & CKarr(i, 2)
    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) = SParr(((i - 1) Mod UBound(SParr)) + 1, 1)
    Tem = Arr(i, 1) & "!@#$" & Arr(i, 2)
    Rws = Dic.Item(Tem)
    Arr(i, 3) = CKarr(Rws, 3)
    Arr(i, 4) = CKarr(Rws, 4)
    Arr(i, 5) = CKarr(Rws, 5)
Next i
Set Dic = Nothing
Range("A5:E" & Range("A4").End(xlDown).Row).Clear
Range("A4").Resize(UBound(Arr), 5) = Arr
ActiveSheet.ListObjects("Table1").Resize Range("A3:B" & Range("A3").End(xlDown).Row)
Range("A3").Resize(UBound(Arr) + 1, 5).Borders.LineStyle = xlContinuous
Application.ScreenUpdating = True
End Sub
 
Upvote 0
HieuCD đã viết:
bạn chạy thử code mới, nhanh hơn nhiều
Mã: 
Sub InsertMa()
Dim DLarr, SParr, CKarr, Arr
Dim i, Rws As Long, Tem As String, Dic As Object
DLarr = Range("A5:A" & Range("A5").End(xlDown).Row)
SParr = Range("B5:B" & Range("B5").End(xlDown).Row)
ReDim Arr(1 To UBound(DLarr) * UBound(SParr), 1 To 5)
Application.ScreenUpdating = False
Sheets(2).Select
CKarr = Range("A4:E" & Range("A4").End(xlDown).Row).Formula
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(CKarr)
    Tem = CKarr(i, 1) & "!@#$" & CKarr(i, 2)
    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) = SParr(((i - 1) Mod UBound(SParr)) + 1, 1)
    Tem = Arr(i, 1) & "!@#$" & Arr(i, 2)
    Rws = Dic.Item(Tem)
    Arr(i, 3) = CKarr(Rws, 3)
    Arr(i, 4) = CKarr(Rws, 4)
    Arr(i, 5) = CKarr(Rws, 5)
Next i
Set Dic = Nothing
Range("A5:E" & Range("A4").End(xlDown).Row).Clear
Range("A4").Resize(UBound(Arr), 5) = Arr
ActiveSheet.ListObjects("Table1").Resize Range("A3:B" & Range("A3").End(xlDown).Row)
Range("A3").Resize(UBound(Arr) + 1, 5).Borders.LineStyle = xlContinuous
Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Nó báo lỗi Subcrip out of range bác ạ
 

File đính kèm

Upvote 0
LYSM đã viết:
Nó báo lỗi Subcrip out of range bác ạ
Nhấp chuột vào đây để mở rộng...
thêm hàm If để bẩy lổi
Mã: 
Sub InsertMa()
Dim DLarr, SParr, CKarr, Arr
Dim i, Rws As Long, Tem As String, Dic As Object
DLarr = Range("A5:A" & Range("A5").End(xlDown).Row)
SParr = Range("B5:B" & Range("B5").End(xlDown).Row)
ReDim Arr(1 To UBound(DLarr) * UBound(SParr), 1 To 5)
Application.ScreenUpdating = False
Sheets(2).Select
CKarr = Range("A4:E" & Range("A4").End(xlDown).Row).Formula
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(CKarr)
    Tem = CKarr(i, 1) & "!@#$" & CKarr(i, 2)
    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) = SParr(((i - 1) Mod UBound(SParr)) + 1, 1)
    Tem = Arr(i, 1) & "!@#$" & Arr(i, 2)
    Rws = Dic.Item(Tem)
    [COLOR=#ff0000]If Rws > 0 Then[/COLOR]
        Arr(i, 3) = CKarr(Rws, 3)
        Arr(i, 4) = CKarr(Rws, 4)
        Arr(i, 5) = CKarr(Rws, 5)
    [COLOR=#ff0000]End If[/COLOR]
Next i
Set Dic = Nothing
Range("A5:E" & Range("A4").End(xlDown).Row).Clear
Range("A4").Resize(UBound(Arr), 5) = Arr
ActiveSheet.ListObjects("Table1").Resize Range("A3:B" & Range("A3").End(xlDown).Row)
Range("A3").Resize(UBound(Arr) + 1, 5).Borders.LineStyle = xlContinuous
Application.ScreenUpdating = True
End Sub
 
Upvote 0
HieuCD đã viết:
thêm hàm If để bẩy lổi
Mã: 
Sub InsertMa()
Dim DLarr, SParr, CKarr, Arr
Dim i, Rws As Long, Tem As String, Dic As Object
DLarr = Range("A5:A" & Range("A5").End(xlDown).Row)
SParr = Range("B5:B" & Range("B5").End(xlDown).Row)
ReDim Arr(1 To UBound(DLarr) * UBound(SParr), 1 To 5)
Application.ScreenUpdating = False
Sheets(2).Select
CKarr = Range("A4:E" & Range("A4").End(xlDown).Row).Formula
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(CKarr)
    Tem = CKarr(i, 1) & "!@#$" & CKarr(i, 2)
    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) = SParr(((i - 1) Mod UBound(SParr)) + 1, 1)
    Tem = Arr(i, 1) & "!@#$" & Arr(i, 2)
    Rws = Dic.Item(Tem)
    [COLOR=#ff0000]If Rws > 0 Then[/COLOR]
        Arr(i, 3) = CKarr(Rws, 3)
        Arr(i, 4) = CKarr(Rws, 4)
        Arr(i, 5) = CKarr(Rws, 5)
    [COLOR=#ff0000]End If[/COLOR]
Next i
Set Dic = Nothing
Range("A5:E" & Range("A4").End(xlDown).Row).Clear
Range("A4").Resize(UBound(Arr), 5) = Arr
ActiveSheet.ListObjects("Table1").Resize Range("A3:B" & Range("A3").End(xlDown).Row)
Range("A3").Resize(UBound(Arr) + 1, 5).Borders.LineStyle = xlContinuous
Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Chạy trực tiếp thì ngon nhưng chạy trong cửa sổ VBE nó cứbáo lỗi “out of memory” là sao bác nhỉ? Vì em muốn tạo 1 nút bấm để khi nàoupdate dữ liệu thì bấm vào đó.
 
Upvote 0
HieuCD đã viết:
thêm hàm If để bẩy lổi
Mã: 
Sub InsertMa()
Dim DLarr, SParr, CKarr, Arr
Dim i, Rws As Long, Tem As String, Dic As Object
DLarr = Range("A5:A" & Range("A5").End(xlDown).Row)
SParr = Range("B5:B" & Range("B5").End(xlDown).Row)
ReDim Arr(1 To UBound(DLarr) * UBound(SParr), 1 To 5)
Application.ScreenUpdating = False
Sheets(2).Select
CKarr = Range("A4:E" & Range("A4").End(xlDown).Row).Formula
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(CKarr)
    Tem = CKarr(i, 1) & "!@#$" & CKarr(i, 2)
    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) = SParr(((i - 1) Mod UBound(SParr)) + 1, 1)
    Tem = Arr(i, 1) & "!@#$" & Arr(i, 2)
    Rws = Dic.Item(Tem)
    [COLOR=#ff0000]If Rws > 0 Then[/COLOR]
        Arr(i, 3) = CKarr(Rws, 3)
        Arr(i, 4) = CKarr(Rws, 4)
        Arr(i, 5) = CKarr(Rws, 5)
    [COLOR=#ff0000]End If[/COLOR]
Next i
Set Dic = Nothing
Range("A5:E" & Range("A4").End(xlDown).Row).Clear
Range("A4").Resize(UBound(Arr), 5) = Arr
ActiveSheet.ListObjects("Table1").Resize Range("A3:B" & Range("A3").End(xlDown).Row)
Range("A3").Resize(UBound(Arr) + 1, 5).Borders.LineStyle = xlContinuous
Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...

Chạy trực tiếp thì ngon nhưng chạy trong cửa sổ VBE nó cứbáo lỗi “out of memory” là sao bác nhỉ? Vì em muốn tạo 1 nút bấm để khi nàoupdate dữ liệu thì bấm vào đó.
PS: Gắn button vào chạy cũng không sao, chỉ khi view code rồiấn vào nút run trên đó sẽ xuất hiện một số lỗi như “out of memory”, “this keyalready associated with an element of this collection|”
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
LYSM đã viết:
Chạy trực tiếp thì ngon nhưng chạy trong cửa sổ VBE nó cứbáo lỗi “out of memory” là sao bác nhỉ? Vì em muốn tạo 1 nút bấm để khi nàoupdate dữ liệu thì bấm vào đó.
Nhấp chuột vào đây để mở rộng...
sheet bangma bạn đã cài chế độ tự động chạy code rồi, thì nút bấm chạy trực tiếp không làm thay đổi kết quả
bạn xóa code trong sheet bangma và chạy code sau
Mã: 
Sub InsertMa()
Dim DLarr, SParr, CKarr, Arr
Dim i, Rws As Long, Tem As String, Dic As Object
[COLOR=#ff0000]With Sheets(1)[/COLOR]
[COLOR=#ff0000]    DLarr = .Range("A5:A" & .Range("A5").End(xlDown).Row)[/COLOR]
[COLOR=#ff0000]    SParr = .Range("B5:B" & .Range("B5").End(xlDown).Row)[/COLOR]
[COLOR=#ff0000]End With[/COLOR]
ReDim Arr(1 To UBound(DLarr) * UBound(SParr), 1 To 5)
Application.ScreenUpdating = False
Sheets(2).Select
CKarr = Range("A4:E" & Range("A4").End(xlDown).Row).Formula
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(CKarr)
    Tem = CKarr(i, 1) & "!@#$" & CKarr(i, 2)
    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) = SParr(((i - 1) Mod UBound(SParr)) + 1, 1)
    Tem = Arr(i, 1) & "!@#$" & Arr(i, 2)
    Rws = Dic.Item(Tem)
    If Rws > 0 Then
        Arr(i, 3) = CKarr(Rws, 3)
        Arr(i, 4) = CKarr(Rws, 4)
        Arr(i, 5) = CKarr(Rws, 5)
    End If
Next i
Set Dic = Nothing
Range("A5:E" & Range("A4").End(xlDown).Row).Clear
Range("A4").Resize(UBound(Arr), 5) = Arr
ActiveSheet.ListObjects("Table1").Resize Range("A3:B" & Range("A3").End(xlDown).Row)
Range("A3").Resize(UBound(Arr) + 1, 5).Borders.LineStyle = xlContinuous
Application.ScreenUpdating = True
End Sub
 
Upvote 0
HieuCD đã viết:
sheet bangma bạn đã cài chế độ tự động chạy code rồi, thì nút bấm chạy trực tiếp không làm thay đổi kết quả
bạn xóa code trong sheet bangma và chạy code sau
Mã: 
Sub InsertMa()
Dim DLarr, SParr, CKarr, Arr
Dim i, Rws As Long, Tem As String, Dic As Object
[COLOR=#ff0000]With Sheets(1)[/COLOR]
[COLOR=#ff0000]    DLarr = .Range("A5:A" & .Range("A5").End(xlDown).Row)[/COLOR]
[COLOR=#ff0000]    SParr = .Range("B5:B" & .Range("B5").End(xlDown).Row)[/COLOR]
[COLOR=#ff0000]End With[/COLOR]
ReDim Arr(1 To UBound(DLarr) * UBound(SParr), 1 To 5)
Application.ScreenUpdating = False
Sheets(2).Select
CKarr = Range("A4:E" & Range("A4").End(xlDown).Row).Formula
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(CKarr)
    Tem = CKarr(i, 1) & "!@#$" & CKarr(i, 2)
    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) = SParr(((i - 1) Mod UBound(SParr)) + 1, 1)
    Tem = Arr(i, 1) & "!@#$" & Arr(i, 2)
    Rws = Dic.Item(Tem)
    If Rws > 0 Then
        Arr(i, 3) = CKarr(Rws, 3)
        Arr(i, 4) = CKarr(Rws, 4)
        Arr(i, 5) = CKarr(Rws, 5)
    End If
Next i
Set Dic = Nothing
Range("A5:E" & Range("A4").End(xlDown).Row).Clear
Range("A4").Resize(UBound(Arr), 5) = Arr
ActiveSheet.ListObjects("Table1").Resize Range("A3:B" & Range("A3").End(xlDown).Row)
Range("A3").Resize(UBound(Arr) + 1, 5).Borders.LineStyle = xlContinuous
Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Nó báo lỗi này bác ạ “this key already associated with anelement of this collection”
em có để file đính kèm bên trên khi báo lỗi đó bác. Vì em làm cho người không biết gì về excel nên nếu lỗi họ không biết xử lý.
 
Lần chỉnh sửa cuối:
Upvote 0
LYSM đã viết:
Chạy trực tiếp thì ngon nhưng chạy trong cửa sổ VBE nó cứbáo lỗi “out of memory” là sao bác nhỉ? Vì em muốn tạo 1 nút bấm để khi nàoupdate dữ liệu thì bấm vào đó.
PS: Gắn button vào chạy cũng không sao, chỉ khi view code rồiấn vào nút run trên đó sẽ xuất hiện một số lỗi như “out of memory”, “this keyalready associated with an element of this collection|”
Nhấp chuột vào đây để mở rộng...

Bạn chạy thử File này coi sao.
Điều kiện mỗi sheet phải có vài dòng dữ liệu
 

File đính kèm

Upvote 0
LYSM đã viết:
Nó báo lỗi này bác ạ “this key already associated with anelement of this collection”
em có để file đính kèm bên trên khi báo lỗi đó bác. Vì em làm cho người không biết gì về excel nên nếu lỗi họ không biết xử lý.
Nhấp chuột vào đây để mở rộng...
nhiều dòng Ma DL và Ma SP trùng nhau nên nó báo lổi, nếu chạy code ngay từ đầu thì không bị tình trạng nầy
bạn chỉnh code lại
Mã: 
Sub InsertMa()
Dim DLarr, SParr, CKarr, Arr
Dim i, Rws As Long, Tem As String, Dic As Object
[COLOR=#ff0000]With Sheets(1)[/COLOR]
[COLOR=#ff0000]    DLarr = .Range("A5:A" & .Range("A5").End(xlDown).Row)[/COLOR]
[COLOR=#ff0000]    SParr = .Range("B5:B" & .Range("B5").End(xlDown).Row)[/COLOR]
[COLOR=#ff0000]End With[/COLOR]
ReDim Arr(1 To UBound(DLarr) * UBound(SParr), 1 To 5)
Application.ScreenUpdating = False
Sheets(2).Select
CKarr = Range("A4:E" & Range("A4").End(xlDown).Row).Formula
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(CKarr)
    Tem = CKarr(i, 1) & "!@#$" & CKarr(i, 2)
[COLOR=#ff0000]    If Not Dic.Exists(Tem) Then Dic.Add Tem, i[/COLOR]
Next i
For i = 1 To UBound(Arr)
    Arr(i, 1) = DLarr(Int((i - 1) / UBound(SParr)) + 1, 1)
    Arr(i, 2) = SParr(((i - 1) Mod UBound(SParr)) + 1, 1)
    Tem = Arr(i, 1) & "!@#$" & Arr(i, 2)
    Rws = Dic.Item(Tem)
    If Rws > 0 Then
        Arr(i, 3) = CKarr(Rws, 3)
        Arr(i, 4) = CKarr(Rws, 4)
        Arr(i, 5) = CKarr(Rws, 5)
    End If
Next i
Set Dic = Nothing
Range("A5:E" & Range("A4").End(xlDown).Row).Clear
Range("A4").Resize(UBound(Arr), 5) = Arr
ActiveSheet.ListObjects("Table1").Resize Range("A3:B" & Range("A3").End(xlDown).Row)
Range("A3").Resize(UBound(Arr) + 1, 5).Borders.LineStyle = xlContinuous
Application.ScreenUpdating = True
End Sub
 
Upvote 0
Vâng, em cám ơn bác #HieuCD và thầy #Ba Tê nhiều.
Em thấy khá ổn rồi, có gì khúc mắc em lại lên hỏi sau ạ.

 
Upvote 0
HieuCD đã viết:
nhờ vậy mà mình có điều kiện luyện code, tới hôm nay mới mò ra được vụ .Formular
còn vụ Table tự động điền công thức thì chịu thua, các bạn có cách nào xử giúp mình
Nhấp chuột vào đây để mở rộng...

Theo tôi thấy thì khả năng code của bạn đã cao lắm rồi, ít nhất cũng hơn tôi. Bạn đã đạt đến mức có thể tự tin mà nói "bất cứ vấn đề gì, chỉ cần giải thích rõ cho tôi thì tôi có thể code"

Cái bạn cần học thêm nữa là phân tích giải thuật và ứng dụng. Bước đầu tiên của phần này là cố gắng đạt đến lúc "bất cứ vấn đề gì Excel cũng giải quyết được, nếu không trực tiếp từ công cụ chính của bảng tính thì vẫn có thể gọi API để thực hiện. Tuy nhiên, đó chỉ là công việc của người viết code. Công việc của người quản lý là phải nhận thức được ngựa kéo xe, trâu kéo cày, tránh dùng lẫn lôn"

LYSM đã viết:
Tìm hết phần mềm rồi bạn, nhưng nó không đáp ứng được các điều kiện cụ thể đặc biệt là tính mở. Đến như công ty mình đang làm có cả ERP mua 100 tr $ mà vẫn phải dùng kết hợp cả excel chứ chưa nói mấy phần mềm khác. Mà có như bạn nói thuê chuyên gia thì họ cũng phải dùng 1 phần mềm nào đó chứ họ có tính nhẩm được đâu. Tiện đây xin bạn giới thiệu giúp mình một vài phần mềm có thể thay thế đc excel.
Nhấp chuột vào đây để mở rộng...

ERP là công cụ quản lý cấp cao. Cơ quan bạn chỉ biết bỏ tiền ra mua phần mềm lấy oai (chắc để trộ khách hàng) chứ không biết chịu khó bỏ công đào tạo chuyên viên sử dụng phần mềm. Chuyên viên sử dụng ERP tự động biết cách sắp sếp chu trình và dữ liệu cho hợp lý, hiệu quả.

Dùng Excel và VBA để xử lý dữ liệu là chuyện bất đắc dĩ. Nếu công ty là cổ phần trách nhiệm, chưa chắc kiểm toán đã chấp nhận loại dữ liệu này. Tầm công ty của bạn là tầm rộng lớn, cái nhìn về công việc cũng phải rộng lớn.
 
Upvote 0
HieuCD đã viết:
nhiều dòng Ma DL và Ma SP trùng nhau nên nó báo lổi, nếu chạy code ngay từ đầu thì không bị tình trạng nầy
bạn chỉnh code lại
Mã: 
Sub InsertMa()
Dim DLarr, SParr, CKarr, Arr
Dim i, Rws As Long, Tem As String, Dic As Object
[COLOR=#ff0000]With Sheets(1)[/COLOR]
[COLOR=#ff0000]    DLarr = .Range("A5:A" & .Range("A5").End(xlDown).Row)[/COLOR]
[COLOR=#ff0000]    SParr = .Range("B5:B" & .Range("B5").End(xlDown).Row)[/COLOR]
[COLOR=#ff0000]End With[/COLOR]
ReDim Arr(1 To UBound(DLarr) * UBound(SParr), 1 To 5)
Application.ScreenUpdating = False
Sheets(2).Select
CKarr = Range("A4:E" & Range("A4").End(xlDown).Row).Formula
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(CKarr)
    Tem = CKarr(i, 1) & "!@#$" & CKarr(i, 2)
[COLOR=#ff0000]    If Not Dic.Exists(Tem) Then Dic.Add Tem, i[/COLOR]
Next i
For i = 1 To UBound(Arr)
    Arr(i, 1) = DLarr(Int((i - 1) / UBound(SParr)) + 1, 1)
    Arr(i, 2) = SParr(((i - 1) Mod UBound(SParr)) + 1, 1)
    Tem = Arr(i, 1) & "!@#$" & Arr(i, 2)
    Rws = Dic.Item(Tem)
    If Rws > 0 Then
        Arr(i, 3) = CKarr(Rws, 3)
        Arr(i, 4) = CKarr(Rws, 4)
        Arr(i, 5) = CKarr(Rws, 5)
    End If
Next i
Set Dic = Nothing
Range("A5:E" & Range("A4").End(xlDown).Row).Clear
Range("A4").Resize(UBound(Arr), 5) = Arr
ActiveSheet.ListObjects("Table1").Resize Range("A3:B" & Range("A3").End(xlDown).Row)
Range("A3").Resize(UBound(Arr) + 1, 5).Borders.LineStyle = xlContinuous
Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Bác @HieuCD ơi, xem lại giúp em code insert Mã với, khi em để lọc cột A hoặc B thì chạy code phần chế độ CK không còn đúng nữa, nó xóa trắng luôn các dòng bị ẩn dưới nó
 

File đính kèm

Upvote 0
LYSM đã viết:
Bác @HieuCD ơi, xem lại giúp em code insert Mã với, khi em để lọc cột A hoặc B thì chạy code phần chế độ CK không còn đúng nữa, nó xóa trắng luôn các dòng bị ẩn dưới nó
Nhấp chuột vào đây để mở rộng...
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
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
 
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 (2 người xem)
Trả lời
2
Đọc
52
A HOANG 620
A
ongke0711
  • Question Question
Trộn dữ liệu từ Excel sang Word mở rộng (phiên bản ongke0711)
    • 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 (1 người xem)
    • Cười
Trả lời
3
Đọc
124
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
50
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? (2 người xem)
    • Cười
Trả lời
4
Đọc
63
Bao Nguyen 89
B
C
Tạo hyperlink hàng loạt (1 người xem)
Trả lời
9
Đọc
5K
online.tanphat
O
TrungChinhs
  • Question Question
Hỏi cách làm tròn số trong VBA (1 người xem)
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
85
nguyendang95
N
Tuấn Bụng Bự
tạo QRcode chuyển khoản ngân hàng (1 người xem)
Trả lời
5
Đọc
216
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 (1 người xem)
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