[Cần giúp đỡ] Code update data vào file excel hàng ngày (1 người xem)

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)
Datcdt2k9

Datcdt2k9

Thành viên hoạt động
Tham gia
27/12/19
Bài viết
109
Được thích
11
Chào mọi người
Em đang gặp vấn đề nếu làm thủ công sẽ mất nhiều thời gian
Vì vậy em đăng lên diễn đàn nhờ mọi người giúp đỡ
Khi Paste data vào cột C (bảng trên )=> chạy code => Data sẽ ra như bảng dưới và khi update data mới dữ liệu sẽ update vào dòng kế tiếp( trong ví dụ data cũ update tới hàng 23, nếu update data mới khi run code update vào dòng 24 trở đi)
Các trường hợp có thể phát sinh em đã tổng hợp trong file
Mong các anh chị giúp đỡ. Em xin cảm ơn
1607769830534.png
 

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
Datcdt2k9 đã viết:
Chào mọi người
Em đang gặp vấn đề nếu làm thủ công sẽ mất nhiều thời gian
Vì vậy em đăng lên diễn đàn nhờ mọi người giúp đỡ
Khi Paste data vào cột C => chạy code => Data sẽ ra như bảng dưới
Các trường hợp có thể phát sinh em đã tổng hợp trong file
Mong các anh chị giúp đỡ. Em xin cảm ơn
View attachment 251108
Nhấp chuột vào đây để mở rộng...
Bạn xem thử thế nào:
Mã: 
Option Explicit
Function Rex(Chuoi As String, Ptn As String) As String
    Dim Re As Object, KQ
    Set Re = CreateObject("vbscript.regexp")
    With Re
        .Global = True
        .MultiLine = True
        .IgnoreCase = True
        .Pattern = Ptn
    End With
    If Re.Test(Chuoi) Then
        Set KQ = Re.Execute(Chuoi)
        Rex = KQ(0)
    Else
        Rex = "#N/A"
    End If
End Function

Sub NTKTNN()
Dim sArr(), dArr(), I&, J&, K&, R&, R1&, SL()
Dim Model$, PGM$, Dai$, CTD$, sType$, Side$, sChuoi$
sArr = Application.InputBox("Chon vùng du lieu nhu ben duoi:", "Select Data Range", "C2:C7", Type:=64)
R = UBound(sArr, 1)
ReDim SL(1 To R)
For I = 1 To R
    sChuoi = sArr(I, 1)
    SL(I) = 1 - Evaluate(Rex(sChuoi, "\d{3}-\d{3}"))
    R1 = R1 + SL(I)
Next
ReDim dArr(1 To R1, 1 To 7)
For I = 1 To R
    sChuoi = sArr(I, 1)
    Side = Left(sChuoi, 1)
    sType = Rex(sChuoi, "\w{2}(?=\.ZIP)")
    If InStr(1, sType, "X", 1) = 0 Then sType = ""
    Dai = Rex(sChuoi, "[A-Z0-9|-]{10,}")
    For J = 1 To SL(I)
        K = K + 1
        CTD = Rex(sChuoi, "[A-Z0-9]{10,}")
        CTD = Left(CTD, Len(CTD) - 3) & Format(Right(CTD, 3) + J - 1, "000")
        Model = Mid(sChuoi, 2, 3) & CTD & sType
        PGM = Mid(sChuoi, 2, Len(sChuoi) - 5)
        dArr(K, 1) = K
        dArr(K, 2) = Model
        dArr(K, 3) = PGM
        dArr(K, 4) = Dai
        dArr(K, 5) = CTD
        dArr(K, 6) = sType
        dArr(K, 7) = Side
    Next
Next
Range("A12").Resize(10000, 7).ClearContents
Range("A12").Resize(K, 7) = dArr
End Sub
 

File đính kèm

Upvote 0
Vâng em kiểm tra ạ
 
Lần chỉnh sửa cuối:
Upvote 0
Nhattanktnn đã viết:
Bạn xem thử thế nào:
Mã: 
Option Explicit
Function Rex(Chuoi As String, Ptn As String) As String
    Dim Re As Object, KQ
    Set Re = CreateObject("vbscript.regexp")
    With Re
        .Global = True
        .MultiLine = True
        .IgnoreCase = True
        .Pattern = Ptn
    End With
    If Re.Test(Chuoi) Then
        Set KQ = Re.Execute(Chuoi)
        Rex = KQ(0)
    Else
        Rex = "#N/A"
    End If
End Function

Sub NTKTNN()
Dim sArr(), dArr(), I&, J&, K&, R&, R1&, SL()
Dim Model$, PGM$, Dai$, CTD$, sType$, Side$, sChuoi$
sArr = Application.InputBox("Chon vùng du lieu nhu ben duoi:", "Select Data Range", "C2:C7", Type:=64)
R = UBound(sArr, 1)
ReDim SL(1 To R)
For I = 1 To R
    sChuoi = sArr(I, 1)
    SL(I) = 1 - Evaluate(Rex(sChuoi, "\d{3}-\d{3}"))
    R1 = R1 + SL(I)
Next
ReDim dArr(1 To R1, 1 To 7)
For I = 1 To R
    sChuoi = sArr(I, 1)
    Side = Left(sChuoi, 1)
    sType = Rex(sChuoi, "\w{2}(?=\.ZIP)")
    If InStr(1, sType, "X", 1) = 0 Then sType = ""
    Dai = Rex(sChuoi, "[A-Z0-9|-]{10,}")
    For J = 1 To SL(I)
        K = K + 1
        CTD = Rex(sChuoi, "[A-Z0-9]{10,}")
        CTD = Left(CTD, Len(CTD) - 3) & Format(Right(CTD, 3) + J - 1, "000")
        Model = Mid(sChuoi, 2, 3) & CTD & sType
        PGM = Mid(sChuoi, 2, Len(sChuoi) - 5)
        dArr(K, 1) = K
        dArr(K, 2) = Model
        dArr(K, 3) = PGM
        dArr(K, 4) = Dai
        dArr(K, 5) = CTD
        dArr(K, 6) = sType
        dArr(K, 7) = Side
    Next
Next
Range("A12").Resize(10000, 7).ClearContents
Range("A12").Resize(K, 7) = dArr
End Sub
Nhấp chuột vào đây để mở rộng...

Cột F (Side) khi run code thì chỉ trả về "B" nên em xin update lại file. Cột C phần kết quả em cần giữ nguyên đuôi zip. Mỗi lần update data mới và run code => Kết quả tự động update vào dòng kế tiếp ( trong ví dụ đang ở dòng 23 khi update data mới => update vào dòng 24 trở đi) và cột STT cũng tự động nhảy tăng dần
Chỉ khi Cột A (STT) có dữ liệu => run code => data update, không có run code =>không update dữ liệu

1607769732124.png
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
befaint đã viết:
Khai báo là static để mỗi vòng lặp không phải dựng lại regex object.
Nhấp chuột vào đây để mở rộng...
Em đã nghĩ tới sau khi gửi code đi, mà gửi rồi nên lười sửa. Vì regex chủ đề nào đó gần đây em cũng có hỏi bác liên quan đến cái này, không nhớ rõ lắm, hình như là "dựng lại regex tốn bộ nhớ hay làm giảm tốc độ" gì đó thì phải
 
Upvote 0
Nhattanktnn đã viết:
Em đã nghĩ tới sau khi gửi code đi, mà gửi rồi nên lười sửa. Vì regex chủ đề nào đó gần đây em cũng có hỏi bác liên quan đến cái này, không nhớ rõ lắm, hình như là "dựng lại regex tốn bộ nhớ hay làm giảm tốc độ" gì đó thì phải
Nhấp chuột vào đây để mở rộng...
Mọi người giúp em với ạ, với lại em muốn sheet 1 chỉ là sheet nhập dữ liệu mới hàng ngày=> khi run code => phần kết quả như trong bảng tự động update vào sheet2 hoặc sheet3...do mình chọn được không ạ
 
Upvote 0
Datcdt2k9 đã viết:
Mọi người giúp em với ạ, với lại em muốn sheet 1 chỉ là sheet nhập dữ liệu mới hàng ngày=> khi run code => phần kết quả như trong bảng tự động update vào sheet2 hoặc sheet3...do mình chọn được không ạ
Nhấp chuột vào đây để mở rộng...
Tôi đã sửa lại code, bạn xem lại nhé (File lúc đầu bạn gửi hình như kết quả không giống bây giờ)
Mã: 
Option Explicit
Function Rex(Chuoi As String, Ptn As String) As String
    Static Re As Object
    Dim KQ
    If Re Is Nothing Then Set Re = CreateObject("vbscript.regexp")
    With Re
        .Global = True
        .MultiLine = True
        .IgnoreCase = True
        .Pattern = Ptn
    End With
    If Re.Test(Chuoi) Then
        Set KQ = Re.Execute(Chuoi)
        Rex = KQ(0)
    End If
End Function

Sub NTKTNN()
Dim sArr(), dArr(), I&, J&, K&, R&, R1&, SL()
Dim Model$, PGM$, Dai$, CTD$, sType$, Side$, sChuoi$, ExtractToSheet$
sArr = Application.InputBox("Chon vùng du lieu nhu ben duoi:", "Select Data Range", "C2:C7", Type:=64)
R = UBound(sArr, 1)
ReDim SL(1 To R)
For I = 1 To R
    sChuoi = sArr(I, 1)
    SL(I) = 1 - Evaluate(Rex(sChuoi, "\d{3}-\d{3}"))
    R1 = R1 + SL(I)
Next
ReDim dArr(1 To R1, 1 To 7)
For I = 1 To R
    sChuoi = sArr(I, 1)
    On Error Resume Next
    Side = Right(Rex(sChuoi, "_[A-Z]{2}(?=_)"), 1)
    On Error GoTo 0
    sType = Rex(sChuoi, "\w{2}(?=\.ZIP)")
    If InStr(1, sType, "X", 1) = 0 Then sType = ""
    Dai = Rex(sChuoi, "[A-Z0-9|-]{10,}")
    For J = 1 To SL(I)
        K = K + 1
        CTD = Rex(sChuoi, "[A-Z0-9]{10,}")
        CTD = Left(CTD, Len(CTD) - 3) & Format(Right(CTD, 3) + J - 1, "000")
        PGM = Mid(sChuoi, 2, Len(sChuoi))
        Model = Left(PGM, 7) & CTD & sType & Side
        dArr(K, 1) = K
        dArr(K, 2) = Model
        dArr(K, 3) = PGM
        dArr(K, 4) = Dai
        dArr(K, 5) = CTD
        dArr(K, 6) = sType
        dArr(K, 7) = Side
    Next
Next
ExtractToSheet = Application.InputBox("Ðiê`n tên sheet", "Xuât Kêt Qua", "Fill auto", Type:=2)
With Sheets(ExtractToSheet)
.Range("A10000").End(xlUp).Offset(2).Resize(10000, 7).ClearContents
.Range("A10000").End(xlUp).Offset(2).Resize(K, 7) = dArr
End With
End Sub
 

File đính kèm

Upvote 0
Nhattanktnn đã viết:
Tôi đã sửa lại code, bạn xem lại nhé (File lúc đầu bạn gửi hình như kết quả không giống bây giờ)
Mã: 
Option Explicit
Function Rex(Chuoi As String, Ptn As String) As String
    Static Re As Object
    Dim KQ
    If Re Is Nothing Then Set Re = CreateObject("vbscript.regexp")
    With Re
        .Global = True
        .MultiLine = True
        .IgnoreCase = True
        .Pattern = Ptn
    End With
    If Re.Test(Chuoi) Then
        Set KQ = Re.Execute(Chuoi)
        Rex = KQ(0)
    End If
End Function

Sub NTKTNN()
Dim sArr(), dArr(), I&, J&, K&, R&, R1&, SL()
Dim Model$, PGM$, Dai$, CTD$, sType$, Side$, sChuoi$, ExtractToSheet$
sArr = Application.InputBox("Chon vùng du lieu nhu ben duoi:", "Select Data Range", "C2:C7", Type:=64)
R = UBound(sArr, 1)
ReDim SL(1 To R)
For I = 1 To R
    sChuoi = sArr(I, 1)
    SL(I) = 1 - Evaluate(Rex(sChuoi, "\d{3}-\d{3}"))
    R1 = R1 + SL(I)
Next
ReDim dArr(1 To R1, 1 To 7)
For I = 1 To R
    sChuoi = sArr(I, 1)
    On Error Resume Next
    Side = Right(Rex(sChuoi, "_[A-Z]{2}(?=_)"), 1)
    On Error GoTo 0
    sType = Rex(sChuoi, "\w{2}(?=\.ZIP)")
    If InStr(1, sType, "X", 1) = 0 Then sType = ""
    Dai = Rex(sChuoi, "[A-Z0-9|-]{10,}")
    For J = 1 To SL(I)
        K = K + 1
        CTD = Rex(sChuoi, "[A-Z0-9]{10,}")
        CTD = Left(CTD, Len(CTD) - 3) & Format(Right(CTD, 3) + J - 1, "000")
        PGM = Mid(sChuoi, 2, Len(sChuoi))
        Model = Left(PGM, 7) & CTD & sType & Side
        dArr(K, 1) = K
        dArr(K, 2) = Model
        dArr(K, 3) = PGM
        dArr(K, 4) = Dai
        dArr(K, 5) = CTD
        dArr(K, 6) = sType
        dArr(K, 7) = Side
    Next
Next
ExtractToSheet = Application.InputBox("Ðiê`n tên sheet", "Xuât Kêt Qua", "Fill auto", Type:=2)
With Sheets(ExtractToSheet)
.Range("A10000").End(xlUp).Offset(2).Resize(10000, 7).ClearContents
.Range("A10000").End(xlUp).Offset(2).Resize(K, 7) = dArr
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Uk bạn,
+ sheet nhập liệu khi chạy code , bạn sửa giúp mình khi có data cột c là run data cột đó=> mình không cần phải chọn vùng=> run xong mk sẽ xóa đi và lần sau lại update data mới vào cột c( coi như sheet này chỉ để nhập liệu hàng ngày)
+ sheet kết quả thì khi run sẽ điền vào dòng tiếp theo
 
Lần chỉnh sửa cuối:
Upvote 0
Datcdt2k9 đã viết:
Uk bạn,
+ sheet nhập liệu khi chạy code , bạn sửa giúp mình khi có data cột c là run data cột đó=> mình không cần phải chọn vùng=> run xong mk sẽ xóa đi và lần sau lại update data mới vào cột c( coi như sheet này chỉ để nhập liệu hàng ngày)
+ sheet kết quả thì khi run sẽ điền vào dòng tiếp theo
Nhấp chuột vào đây để mở rộng...
Tôi không thích thêm bớt ý tưởng kiểu như này, rõ ràng một lần luôn để chỉnh
Bạn tạo lại file gồm sheet data (để nhập liệu), sheet KQ (để ghi kết quả)
Muốn kết quả ghi vào sheet KQ từ dòng nào ghi chú rõ ra (và có cần phải chọn sheet để ghi kết quả hay không, hay chỉ cần ghi vào sheet KQ là được?)
 
Upvote 0
Nhattanktnn đã viết:
..., hình như là "dựng lại regex tốn bộ nhớ hay làm giảm tốc độ" gì đó thì phải
Nhấp chuột vào đây để mở rộng...
1. tốn bộ nhớ: tuỳ theo hàm được gọi bằng cách nào.
- nếu dùng bộ nhớ chung (heap - biến toàn cục hoặc biến static) thì nó luôn nằm đó. Và sẽ tốn bộ nhớ cho nó hơn là gọi hàm xong thì giải phóng đi.
- nếu dùng bộ nhớ ngăn xếp (stack - biến nội bộ) thì nó sẽ được giải phóng sau khi hàm chạy xong. Tuy nhiên, nếu hàm chưa chạy xong (gọi hàm khác, đệ quy) thì nó còn nằm đó, đệ quy vài vòng sẽ hết bộ nhớ ngăn xếp.
2. giảm tốc độ: nếu bộ nhớ lớn thì tuy chương trình "giải phóng bộ nhớ" nhưng nó vẫn còn nằm đó. Lúc cần nhập trở lại thì nhập cũng khá nhanh - Hệ thống (Windows) chỉ cần nối lại các địa chỉ hàm, tham số,... . Các phương tiện của VBScript hầu hết là COM, Windows biết cách tối ưu cách trữ trong bộ nhớ. Cái khác nhau là:
(a) nếu máy xịn, Windows sẽ có khuynh hướng đưa các COM vào phần cache (phần truy vấn trực tiếp nhanh của Processor) và sẽ chạy nhanh hơn.
(b) với các hệ thống hiệu quả, chính cái cỗ máy Regex sẽ "nhớ" các chi tiết trước đó và làm việc hiệu quả hơn. Trong trường hợp này thì giữ nó lại, không giải phóng thì nó sẽ làm việc hiệu quả hơn.

Tuy nhiên, những điều trên chỉ là lý thuyết lập trình. Nếu một dối tượng (COM object) được sử dụng cả trăm cả ngàn lần thì giữ nó đừng giải phóng là chuyện tập thói quen tốt thôi.
 
Upvote 0
VetMini đã viết:
1. tốn bộ nhớ: tuỳ theo hàm được gọi bằng cách nào.
- nếu dùng bộ nhớ chung (heap - biến toàn cục hoặc biến static) thì nó luôn nằm đó. Và sẽ tốn bộ nhớ cho nó hơn là gọi hàm xong thì giải phóng đi.
- nếu dùng bộ nhớ ngăn xếp (stack - biến nội bộ) thì nó sẽ được giải phóng sau khi hàm chạy xong. Tuy nhiên, nếu hàm chưa chạy xong (gọi hàm khác, đệ quy) thì nó còn nằm đó, đệ quy vài vòng sẽ hết bộ nhớ ngăn xếp.
2. giảm tốc độ: nếu bộ nhớ lớn thì tuy chương trình "giải phóng bộ nhớ" nhưng nó vẫn còn nằm đó. Lúc cần nhập trở lại thì nhập cũng khá nhanh - Hệ thống (Windows) chỉ cần nối lại các địa chỉ hàm, tham số,... . Các phương tiện của VBScript hầu hết là COM, Windows biết cách tối ưu cách trữ trong bộ nhớ. Cái khác nhau là:
(a) nếu máy xịn, Windows sẽ có khuynh hướng đưa các COM vào phần cache (phần truy vấn trực tiếp nhanh của Processor) và sẽ chạy nhanh hơn.
(b) với các hệ thống hiệu quả, chính cái cỗ máy Regex sẽ "nhớ" các chi tiết trước đó và làm việc hiệu quả hơn. Trong trường hợp này thì giữ nó lại, không giải phóng thì nó sẽ làm việc hiệu quả hơn.

Tuy nhiên, những điều trên chỉ là lý thuyết lập trình. Nếu một dối tượng (COM object) được sử dụng cả trăm cả ngàn lần thì giữ nó đừng giải phóng là chuyện tập thói quen tốt thôi.
Nhấp chuột vào đây để mở rộng...
Cảm ơn bác đã chia sẻ
 
Upvote 0
Nhattanktnn đã viết:
Tôi không thích thêm bớt ý tưởng kiểu như này, rõ ràng một lần luôn để chỉnh
Bạn tạo lại file gồm sheet data (để nhập liệu), sheet KQ (để ghi kết quả)
Muốn kết quả ghi vào sheet KQ từ dòng nào ghi chú rõ ra (và có cần phải chọn sheet để ghi kết quả hay không, hay chỉ cần ghi vào sheet KQ là được?)
Nhấp chuột vào đây để mở rộng...
ok bạn ,mình gửi lại file bạn giúp mình hoàn thành nốt nhé
Sheet nhập liệu (data mình sẽ paste vào cột C, số lượng dòng tùy ý, không phải chọn vùng dữ liệu như code cũ) => Run code sẽ tự nhận data có trong các dòng ở cột c và tách ra Sheet KQ=> run code xong thì sẽ nhảy sang sheet KQ để mình có thể xem KQ bên sheet KQ.=> Sheet kết quả mỗi lần nhấn chạy code thì dữ liệu sẽ nằm dòng kế tiếp của lần run trước đó(ví dụ lần 1 run tới dòng 12, lần 2 run data vào dòng 13 trở đi, cứ thế lần lượt)
Mình cảm ơn nhé!!!
 

File đính kèm

Upvote 0
Datcdt2k9 đã viết:
ok bạn ,mình gửi lại file bạn giúp mình hoàn thành nốt nhé
Sheet nhập liệu (data mình sẽ paste vào cột C, số lượng dòng tùy ý, không phải chọn vùng dữ liệu như code cũ) => Run code sẽ tự nhận data có trong các dòng ở cột c và tách ra Sheet KQ=> run code xong thì sẽ nhảy sang sheet KQ để mình có thể xem KQ bên sheet KQ.=> Sheet kết quả mỗi lần nhấn chạy code thì dữ liệu sẽ nằm dòng kế tiếp của lần run trước đó(ví dụ lần 1 run tới dòng 12, lần 2 run data vào dòng 13 trở đi, cứ thế lần lượt)
Mình cảm ơn nhé!!!
Nhấp chuột vào đây để mở rộng...
Chú ý, do yêu cầu của bạn là ghi dữ liệu kế tiếp, do đó với cùng 1 dữ liệu ở sheet NhapLieu, nếu bấm Run Code button 2 lần thì sẽ cho ra 2 lần kết quả bên sheet KQ
 

File đính kèm

Upvote 0
Datcdt2k9 đã viết:
ok bạn ,mình gửi lại file bạn giúp mình hoàn thành nốt nhé
Sheet nhập liệu (data mình sẽ paste vào cột C, số lượng dòng tùy ý, không phải chọn vùng dữ liệu như code cũ) => Run code sẽ tự nhận data có trong các dòng ở cột c và tách ra Sheet KQ=> run code xong thì sẽ nhảy sang sheet KQ để mình có thể xem KQ bên sheet KQ.=> Sheet kết quả mỗi lần nhấn chạy code thì dữ liệu sẽ nằm dòng kế tiếp của lần run trước đó(ví dụ lần 1 run tới dòng 12, lần 2 run data vào dòng 13 trở đi, cứ thế lần lượt)
Mình cảm ơn nhé!!!
Nhấp chuột vào đây để mở rộng...
Ok bạn, cái này mình kiểm soát được, miễn là kết quả cứ nối tiếp nhau và stt cũng tự động +1 sau mỗi lần run code là được bạn ạ
 
Upvote 0
Datcdt2k9 đã viết:
Mình cảm ơn bạn nhé, mình test ok rồi
Nhấp chuột vào đây để mở rộng...
Lần sau có trích dẫn thì trích dẫn bài của tôi, lỡ hỏi giúp đỡ gì tôi còn có thông báo, biết để vào xem lại cho bạn. Cả 2 bài #15 và #16 bạn đầu trích dẫn câu của bạn rồi trả lời, tôi đâu có biết. Rút kinh nghiệm cho những bài sau này nhé
 
Upvote 0
Nhattanktnn đã viết:
Lần sau có trích dẫn thì trích dẫn bài của tôi, lỡ hỏi giúp đỡ gì tôi còn có thông báo, biết để vào xem lại cho bạn. Cả 2 bài #15 và #16 bạn đầu trích dẫn câu của bạn rồi trả lời, tôi đâu có biết. Rút kinh nghiệm cho những bài sau này nhé
Nhấp chuột vào đây để mở rộng...
Ok bạn, mình cảm ơn nhé, mình rút kinh nghiệm lần sau
 
Upvote 0
Nhattanktnn đã viết:
Chú ý, do yêu cầu của bạn là ghi dữ liệu kế tiếp, do đó với cùng 1 dữ liệu ở sheet NhapLieu, nếu bấm Run Code button 2 lần thì sẽ cho ra 2 lần kết quả bên sheet KQ
Nhấp chuột vào đây để mở rộng...
Mình nhờ bạn thêm chút nữa. Sau này mình có thể mở rộng thêm dữ liệu, code hiện tại chỉ copy từ cột A tới cột G, bạn tối ưu code giúp mình có thể copy data từ cột A tới cột K " Sheet nhap lieu" để sau này mình có thể thêm trường dữ liệu túy ý, file mình upload bên dưới nhé

1608043348455.png
1608043376820.png
 

File đính kèm

Upvote 0
Datcdt2k9 đã viết:
Mình nhờ bạn thêm chút nữa. Sau này mình có thể mở rộng thêm dữ liệu, code hiện tại chỉ copy từ cột A tới cột G, bạn tối ưu code giúp mình có thể copy data từ cột A tới cột K " Sheet nhap lieu" để sau này mình có thể thêm trường dữ liệu túy ý, file mình upload bên dưới nhé

View attachment 251282
View attachment 251283
Nhấp chuột vào đây để mở rộng...
Do tôi thấy bạn có thay đổi tên sheet xuất kết quả (mà bạn không biết nên sửa cả function), nên rong code tôi thêm đoạn này:
Mã: 
Set Ws = Sheets("KQ")
Nếu bạn muốn thay đổi xuất kết quả sang sheet khác thì sửa tên sheet trong dấu ngoặc kép, còn lại không thay đổi gì
 

File đính kèm

Upvote 0
Nhattanktnn đã viết:
Do tôi thấy bạn có thay đổi tên sheet xuất kết quả (mà bạn không biết nên sửa cả function), nên rong code tôi thêm đoạn này:
Mã: 
Set Ws = Sheets("KQ")
Nếu bạn muốn thay đổi xuất kết quả sang sheet khác thì sửa tên sheet trong dấu ngoặc kép, còn lại không thay đổi gì
Nhấp chuột vào đây để mở rộng...
Uk cái này mình đã tùy biến thay tên sheet trong từng code và tạo button khi muốn xuất kết quả sang sheet cần.Nhưng bây giờ mình muốn add thêm cột mở rộng bên sheet nhaplieu để sau này có thể thêm trường dữ liệu nào đó, trong bài mình muốn mở rộng tới cột K
 
Upvote 0
Nhattanktnn đã viết:
Do tôi thấy bạn có thay đổi tên sheet xuất kết quả (mà bạn không biết nên sửa cả function), nên rong code tôi thêm đoạn này:
Mã: 
Set Ws = Sheets("KQ")
Nếu bạn muốn thay đổi xuất kết quả sang sheet khác thì sửa tên sheet trong dấu ngoặc kép, còn lại không thay đổi gì
Nhấp chuột vào đây để mở rộng...
Bạn kiểm tra giúp mình, code không tách được dải( ví dụ VQ1902OFA100-102) => Run code báo lỗi bạn ạ. Dải đơn ví dụ VQ2002OFA302 thì tách ok.
 
Upvote 0
Datcdt2k9 đã viết:
Bạn kiểm tra giúp mình, code không tách được dải( ví dụ VQ1902OFA100-102) => Run code báo lỗi bạn ạ. Dải đơn ví dụ VQ2002OFA302 thì tách ok.
Nhấp chuột vào đây để mở rộng...
Dữ liệu còn kiểu nào khác nữa không? lúc đầu bạn bảo liệt kê hết kiểu rồi, tôi không thấy có kiểu đơn như vậy
sửa chỗ này:
Mã: 
    SL(I) = 1 - Evaluate(Rex(sChuoi, "\d{3}-\d{3}"))
Thành:
Mã: 
On Error Resume Next
    SL(I) = 1
    SL(I) = 1 - Evaluate(Rex(sChuoi, "\d{3}-\d{3}"))
On Error GoTo 0
 
Upvote 0
Nhattanktnn đã viết:
Dữ liệu còn kiểu nào khác nữa không? lúc đầu bạn bảo liệt kê hết kiểu rồi, tôi không thấy có kiểu đơn như vậy
sửa chỗ này:
Mã: 
    SL(I) = 1 - Evaluate(Rex(sChuoi, "\d{3}-\d{3}"))
Thành:
Mã: 
On Error Resume Next
    SL(I) = 1
    SL(I) = 1 - Evaluate(Rex(sChuoi, "\d{3}-\d{3}"))
On Error GoTo 0
Nhấp chuột vào đây để mở rộng...
Từ đầu bài mình đăng là có
Nhattanktnn đã viết:
Dữ liệu còn kiểu nào khác nữa không? lúc đầu bạn bảo liệt kê hết kiểu rồi, tôi không thấy có kiểu đơn như vậy
sửa chỗ này:
Mã: 
    SL(I) = 1 - Evaluate(Rex(sChuoi, "\d{3}-\d{3}"))
Thành:
Mã: 
On Error Resume Next
    SL(I) = 1
    SL(I) = 1 - Evaluate(Rex(sChuoi, "\d{3}-\d{3}"))
On Error GoTo 0
Nhấp chuột vào đây để mở rộng...
Ok mình check ok rồi bạn ạ, file lúc dầu mình gửi có mà nhỉ
 
Upvote 0
Nhattanktnn đã viết:
Dữ liệu còn kiểu nào khác nữa không? lúc đầu bạn bảo liệt kê hết kiểu rồi, tôi không thấy có kiểu đơn như vậy
sửa chỗ này:
Mã: 
    SL(I) = 1 - Evaluate(Rex(sChuoi, "\d{3}-\d{3}"))
Thành:
Mã: 
On Error Resume Next
    SL(I) = 1
    SL(I) = 1 - Evaluate(Rex(sChuoi, "\d{3}-\d{3}"))
On Error GoTo 0
Nhấp chuột vào đây để mở rộng...
mình nhờ bạn chút nhé, mình có file cần thống kê ra các giá trị NG khi sau khi filter mà hành động lần lượt, lọc giá trị NG lần lượt từng cột và copy giá trị sau khi lọc sang 1 sheet "KQ"=> mình có giải thích kĩ trong file rồi, bạn giúp mình với nhé
1608818332833.png
 

File đính kèm

Upvote 0
Datcdt2k9 đã viết:
mình nhờ bạn chút nhé, mình có file cần thống kê ra các giá trị NG khi sau khi filter mà hành động lần lượt, lọc giá trị NG lần lượt từng cột và copy giá trị sau khi lọc sang 1 sheet "KQ"=> mình có giải thích kĩ trong file rồi, bạn giúp mình với nhé
View attachment 251776
Nhấp chuột vào đây để mở rộng...
Thử code này xem:
Mã: 
Option Explicit
Sub NTKTNN()
Dim sArr(), dArr(), I&, J&, K&, N&, Txt$, U1&, U2&, ColName$
With Sheets("Data")
    sArr = .Range("R3:AH" & .Cells(.Rows.Count, "AH").End(xlUp).Row).Value
    U1 = UBound(sArr, 1): U2 = UBound(sArr, 2)
    ReDim dArr(1 To U1, 1 To U2 + 2)
    For I = 4 To U2
        For J = 1 To U1
            Txt = LCase(Trim(sArr(J, I)))
            If Txt = "ng" Then
                N = N + 1
                For K = 1 To U2
                    dArr(N, K + 1) = sArr(J, K)
                Next
                dArr(N, 1) = N
                ColName = WorksheetFunction.Substitute(.Cells(1, I + 17).Address(0, 0), 1, "")
                dArr(N, U2 + 2) = "Giá tri NG côt " & ColName
            End If
        Next
    Next
End With
With Sheets("KQ")
    .Range("A3:S10000").Clear
    .Range("A3").Resize(N, U2 + 2) = dArr
End With
End Sub
 
Upvote 0
Nhattanktnn đã viết:
Thử code này xem:
Mã: 
Option Explicit
Sub NTKTNN()
Dim sArr(), dArr(), I&, J&, K&, N&, Txt$, U1&, U2&, ColName$
With Sheets("Data")
    sArr = .Range("R3:AH" & .Cells(.Rows.Count, "AH").End(xlUp).Row).Value
    U1 = UBound(sArr, 1): U2 = UBound(sArr, 2)
    ReDim dArr(1 To U1, 1 To U2 + 2)
    For I = 4 To U2
        For J = 1 To U1
            Txt = LCase(Trim(sArr(J, I)))
            If Txt = "ng" Then
                N = N + 1
                For K = 1 To U2
                    dArr(N, K + 1) = sArr(J, K)
                Next
                dArr(N, 1) = N
                ColName = WorksheetFunction.Substitute(.Cells(1, I + 17).Address(0, 0), 1, "")
                dArr(N, U2 + 2) = "Giá tri NG côt " & ColName
            End If
        Next
    Next
End With
With Sheets("KQ")
    .Range("A3:S10000").Clear
    .Range("A3").Resize(N, U2 + 2) = dArr
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Bạn giúp mình edit code sao cho giá trị "NG" sang sheet KQ được tô màu và tối ưu 1 chút cho mình cột KQ mong muốn bên sheet KQ ( lấy tên cột NG thực tế U1,V1...AH1 bên sheet Data. U1(The tich), V1(BGA)...AH(TT2).Mình xin gửi lại file chi tiết
 

File đính kèm

  • filter NG.xlsm
    filter NG.xlsm
    27 KB · Đọc: 9
  • 1608975532130.png
    1608975532130.png
    273.1 KB · Đọc: 11
Upvote 0
Datcdt2k9 đã viết:
Bạn giúp mình edit code sao cho giá trị "NG" sang sheet KQ được tô màu và tối ưu 1 chút cho mình cột KQ mong muốn bên sheet KQ ( lấy tên cột NG thực tế U1,V1...AH1 bên sheet Data. U1(The tich), V1(BGA)...AH(TT2).Mình xin gửi lại file chi tiết
Nhấp chuột vào đây để mở rộng...
Chạy thử
Mã: 
Sub XYZ()
  Dim sArr(), aTD(), Res()
  Dim i&, j&, c&, k&, sRow&, sCol&, tmp$

  With Sheets("Data")
    aTD = .Range("R1:AH1").Value
    sArr = .Range("R3", .Range("AH" & Rows.Count).End(xlUp)).Value
    sRow = UBound(sArr, 1): sCol = UBound(sArr, 2)
    ReDim Res(1 To sRow, 1 To sCol + 2)
  End With
  For j = 4 To sCol
    For i = 1 To sRow
      tmp = LCase(sArr(i, j))
      If tmp = "ng" Then
        k = k + 1
        Res(k, 1) = k
        For c = 1 To sCol
          Res(k, c + 1) = sArr(i, c)
          sArr(i, c) = Empty
        Next c
        Res(k, sCol + 2) = "Giá tri NG côt " & aTD(1, j) & "=> Check " & aTD(1, j)
      End If
    Next i
  Next j
  With Sheets("KQ")
    .Range("A3:S10000").Clear
    .Range("A3").Resize(k, sCol + 2) = Res
  End With
End Sub
 
Upvote 0
HieuCD đã viết:
Chạy thử
Mã: 
Sub XYZ()
  Dim sArr(), aTD(), Res()
  Dim i&, j&, c&, k&, sRow&, sCol&, tmp$

  With Sheets("Data")
    aTD = .Range("R1:AH1").Value
    sArr = .Range("R3", .Range("AH" & Rows.Count).End(xlUp)).Value
    sRow = UBound(sArr, 1): sCol = UBound(sArr, 2)
    ReDim Res(1 To sRow, 1 To sCol + 2)
  End With
  For j = 4 To sCol
    For i = 1 To sRow
      tmp = LCase(sArr(i, j))
      If tmp = "ng" Then
        k = k + 1
        Res(k, 1) = k
        For c = 1 To sCol
          Res(k, c + 1) = sArr(i, c)
          sArr(i, c) = Empty
        Next c
        Res(k, sCol + 2) = "Giá tri NG côt " & aTD(1, j) & "=> Check " & aTD(1, j)
      End If
    Next i
  Next j
  With Sheets("KQ")
    .Range("A3:S10000").Clear
    .Range("A3").Resize(k, sCol + 2) = Res
  End With
End Sub
[/QUOTE]
Nhấp chuột vào đây để mở rộng...

HieuCD đã viết:
Chạy thử
Mã: 
Sub XYZ()
  Dim sArr(), aTD(), Res()
  Dim i&, j&, c&, k&, sRow&, sCol&, tmp$

  With Sheets("Data")
    aTD = .Range("R1:AH1").Value
    sArr = .Range("R3", .Range("AH" & Rows.Count).End(xlUp)).Value
    sRow = UBound(sArr, 1): sCol = UBound(sArr, 2)
    ReDim Res(1 To sRow, 1 To sCol + 2)
  End With
  For j = 4 To sCol
    For i = 1 To sRow
      tmp = LCase(sArr(i, j))
      If tmp = "ng" Then
        k = k + 1
        Res(k, 1) = k
        For c = 1 To sCol
          Res(k, c + 1) = sArr(i, c)
          sArr(i, c) = Empty
        Next c
        Res(k, sCol + 2) = "Giá tri NG côt " & aTD(1, j) & "=> Check " & aTD(1, j)
      End If
    Next i
  Next j
  With Sheets("KQ")
    .Range("A3:S10000").Clear
    .Range("A3").Resize(k, sCol + 2) = Res
  End With
End Sub
Nhấp chuột vào đây để mở rộng...
mình đã test thử, giá trị NG bên sheet KQ vẫn chưa được tô màu giống sheet data, với mình cần sheet Data có bao nhiêu giá trị NG sẽ xuất ra cần ấy giá trị trong sheet KQ .Trong ví dụ là 15 giá trị NG, code của bạn ra 9 giá trị do có giá trị NG nằm cùng hàng, mình cần tách riêng các giá trị này, mỗi giá trị NG là 1 hàng bạn ạ
 
Upvote 0
Datcdt2k9 đã viết:
mình đã test thử, giá trị NG bên sheet KQ vẫn chưa được tô màu giống sheet data, với mình cần sheet Data có bao nhiêu giá trị NG sẽ xuất ra cần ấy giá trị trong sheet KQ .Trong ví dụ là 15 giá trị NG, code của bạn ra 9 giá trị do có giá trị NG nằm cùng hàng, mình cần tách riêng các giá trị này, mỗi giá trị NG là 1 hàng bạn ạ
Nhấp chuột vào đây để mở rộng...
Chỉnh lại
Mã: 
Option Explicit
Option Compare Text

Sub XYZ()
  Dim sArr(), aTD(), Res(), Rng As Range
  Dim i&, j&, c&, k&, sRow&, sCol&, tmp$

With Sheets("Data")
  aTD = .Range("R1:AH1").Value
  sArr = .Range("R3", .Range("AH" & Rows.Count).End(xlUp)).Value
  sRow = UBound(sArr, 1): sCol = UBound(sArr, 2)
  ReDim Res(1 To sRow, 1 To sCol + 2)
End With
 
With Sheets("KQ")
  .Range("A3:S10000").Clear
  For j = 4 To sCol
    For i = 1 To sRow
      tmp = LCase(sArr(i, j))
      If sArr(i, j) = "ng" Then
        k = k + 1
        Res(k, 1) = k
        For c = 1 To 3
          Res(k, c + 1) = sArr(i, c)
        Next c
        For c = 4 To sCol
          Res(k, c + 1) = sArr(i, c)
          If sArr(i, c) = "ng" Then
            If Rng Is Nothing Then
              Set Rng = .Cells(k + 2, c + 1)
            Else
              Set Rng = Union(Rng, .Cells(k + 2, c + 1))
              If Rng.Count = 50 Then
                Rng.Interior.ColorIndex = 40
                Set Rng = Nothing
              End If
            End If
          End If
        Next c
        Res(k, sCol + 2) = "Giá tri NG côt " & aTD(1, j) & "=> Check " & aTD(1, j)
      End If
    Next i
  Next j
  If k Then .Range("A3").Resize(k, sCol + 2) = Res
  If Not Rng Is Nothing Then Rng.Interior.ColorIndex = 40
End With
End Sub
 
Upvote 0
HieuCD đã viết:
Chỉnh lại
Mã: 
Option Explicit
Option Compare Text

Sub XYZ()
  Dim sArr(), aTD(), Res(), Rng As Range
  Dim i&, j&, c&, k&, sRow&, sCol&, tmp$

With Sheets("Data")
  aTD = .Range("R1:AH1").Value
  sArr = .Range("R3", .Range("AH" & Rows.Count).End(xlUp)).Value
  sRow = UBound(sArr, 1): sCol = UBound(sArr, 2)
  ReDim Res(1 To sRow, 1 To sCol + 2)
End With

With Sheets("KQ")
  .Range("A3:S10000").Clear
  For j = 4 To sCol
    For i = 1 To sRow
      tmp = LCase(sArr(i, j))
      If sArr(i, j) = "ng" Then
        k = k + 1
        Res(k, 1) = k
        For c = 1 To 3
          Res(k, c + 1) = sArr(i, c)
        Next c
        For c = 4 To sCol
          Res(k, c + 1) = sArr(i, c)
          If sArr(i, c) = "ng" Then
            If Rng Is Nothing Then
              Set Rng = .Cells(k + 2, c + 1)
            Else
              Set Rng = Union(Rng, .Cells(k + 2, c + 1))
              If Rng.Count = 50 Then
                Rng.Interior.ColorIndex = 40
                Set Rng = Nothing
              End If
            End If
          End If
        Next c
        Res(k, sCol + 2) = "Giá tri NG côt " & aTD(1, j) & "=> Check " & aTD(1, j)
      End If
    Next i
  Next j
  If k Then .Range("A3").Resize(k, sCol + 2) = Res
  If Not Rng Is Nothing Then Rng.Interior.ColorIndex = 40
End With
End Sub
Nhấp chuột vào đây để mở rộng...
ok mình cảm ơn bạn. mình check ok rồi => Bạn giúp mình khi run xong đồng thời excel cũng tự động nhảy sang sheet KQ để minh view luôn kết quả bạn ạ
=> bên sheet KQ data tới đâu thì all boders giúp mình tới đó, sau này mình không phải thực hiện kẻ bảng nhiều lần
Đây là dữ liệu khi chạy code xong chưa được kẻ bảng

1609065560425.png
 
Lần chỉnh sửa cuối:
Upvote 0
Nhattanktnn đã viết:
Lần sau có trích dẫn thì trích dẫn bài của tôi, lỡ hỏi giúp đỡ gì tôi còn có thông báo, biết để vào xem lại cho bạn. Cả 2 bài #15 và #16 bạn đầu trích dẫn câu của bạn rồi trả lời, tôi đâu có biết. Rút kinh nghiệm cho những bài sau này nhé
Nhấp chuột vào đây để mở rộng...
Sau thời gian sử dụng mình gặp vấn đề dữ liệu update hàng ngày có 1 số dòng data định dạng khác trong code bạn viết, run sẽ báo lỗi và do quá nhiều dòng nên mình không tìm được dòng nào sai để sửa
=> bạn giúp mình thêm code phát hiện lỗi dòng nào sai để mình tìm sửa được không
=> Khi run code báo lỗi sẽ trả về số thứ tự dòng đang bị lỗi để mình tìm và sửa bạn ạ.Mình cảm ơn
 
Upvote 0
Nhattanktnn đã viết:
Dữ liệu còn kiểu nào khác nữa không? lúc đầu bạn bảo liệt kê hết kiểu rồi, tôi không thấy có kiểu đơn như vậy
sửa chỗ này:
Mã: 
    SL(I) = 1 - Evaluate(Rex(sChuoi, "\d{3}-\d{3}"))
Thành:
Mã: 
On Error Resume Next
    SL(I) = 1
    SL(I) = 1 - Evaluate(Rex(sChuoi, "\d{3}-\d{3}"))
On Error GoTo 0
Nhấp chuột vào đây để mở rộng...
Chào bạn, mình đang gặp vấn đề với file dữ liệu do dữ liệu của mình có thay đổi chút so với dữ liệu trước kia mình nhờ bạn viêt code nên lên đây tìm lại bài để nhờ bạn giúp mình, dữ liệu của mình có update thêm cột Run Jig (J) và cột ECN (K) nên khi tách, code tách sai dữ liệu, bạn giúp mình tách dữ liệu như hình dưới , bên dưới=> Khi run code nhấn K4 bên sheet NhapLieu => Data sẽ update Kết quả như sheet K4.Bạn giúp mình với
1611582103795.png
1611582414880.png
 

File đính kèm

Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

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

hongphuong1997
Nên sử dụng Chatgpt hay Copilot (1 người xem)
Trả lời
0
Đọc
28
hongphuong1997
hongphuong1997
N
Tạo file Excel dùng VBA để lấy và nối dữ liệu từ các files excel (1 người xem)
Trả lời
39
Đọc
6K
hungnv_thct2026
H
S
Power BI. Một quá trình đòi hỏi sự kiên nhẫn.
Trả lời
4
Đọc
148
SteveNguyen1991
S
2
  • Question Question
Hỏi cách in phiếu điều tra PCGD-XMC từ file dữ liệu mẫu xuất ra từ hệ thống PCGD-XMC của Bộ GD
    • Thích
Trả lời
15
Đọc
943
Hoàng Tuấn 868
H
SA_DQ
  • Question Question
Bài tập VBA cho những người rỗi. . . đủ thứ! (2 người xem)
    • Cười
    • Yêu thích
Trả lời
21
Đọc
690
Phuocam
Phuocam
H
Giúp mình ghép nhiều file thành một file.
Trả lời
9
Đọc
310
Hoàng Tuấn 868
H
H
  • Question Question
Dò tìm giá trị từ bảng khác theo cột
Trả lời
5
Đọc
93
ptm0412
ptm0412
L
Cách bật/tắt đèn led thứ 3 trên bàn phím cơ
Trả lời
1
Đọc
52
HUONGHCKT
H
C
Không thể group cột trong excel
Trả lời
10
Đọc
12K
ptm0412
ptm0412
A
  • Question Question
Em nhờ anh/chị/em/chú/bác giúp em viết code tổng hợp dữ liệu. em tính công thức nó nặng quá. em cám ơn
Trả lời
14
Đọc
959
Hoàng Tuấn 868
H
H
Xin giúp đỡ về phổ cập
Trả lời
5
Đọc
985
tranvanky8111967
T
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (1 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
3 4 5
Trả lời
420
Đọc
52K
maingoctu89
M
P
Xin giúp sửa code VBA tổng hợp sản lượng theo format file FCS đổ từ hệ thống ERP.
Trả lời
14
Đọc
296
DeTong
D
L
Nhờ anh chị giúp đỡ công thức hàm len
Trả lời
44
Đọc
737
khuong182018
khuong182018
hongphuong1997
Cách tô màu một dòng theo chiều cao tùy ý
Trả lời
5
Đọc
194
hongphuong1997
hongphuong1997
D
nhờ anh chị giải thích hàm hstack
Trả lời
2
Đọc
141
dungpham01
D
L
Nhờ anh chị giúp giúp đỡ hàm ạ
    • Chấp nhận
Trả lời
12
Đọc
367
Phan Thế Hiệp
Phan Thế Hiệp
vuthaiha90
Lọc dữ liệu không trùng và trả kết quả về 1 dòng
Trả lời
6
Đọc
193
Duy Tùng 9x
Duy Tùng 9x
B
Copy textbox giữa 2 userform
Trả lời
6
Đọc
236
Bảo_Anh_
B
L
  • Question Question
Khi chọn sheet 2, thì mặc định chọn ô A5
Trả lời
1
Đọc
108
vu_tuan_manh_linh
vu_tuan_manh_linh
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

Thời gian đếm ngược.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom