Dò tìm dữ liệu từ một sheet CSDL có sẵn

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

adoonis

Thành viên mới
Tham gia
4/5/08
Bài viết
9
Được thích
7
Kính chào các sư huynh em đang tính tự lập một File Dự Toán bằng Excel, nhưng đến bước phân tích vật tư thì đang bị potay nghĩ mãi mà chẳng biết làm cách nào. Cụ thể như sau, hiện em có một sheet chứa CSDL về định mức ( gồm nhiều các loại hạng mục kèm mã hiệu của các hạng mục đó), và khi phân tích vật tư em chỉ cần dùng một vài mã hiệu ở bên sheet PTVT. em muốn khi mình gõ mã hiệu bên Sheet PTVT Excel thì tự động dò tìm bên sheet DM mã hiệu và các hạng mục. em rất mong được các sư huy giúp đỡ, em xin chân thành cảm ơn.
 

File đính kèm

adoonis đã viết:
Kính chào các sư huynh em đang tính tự lập một File Dự Toán bằng Excel, nhưng đến bước phân tích vật tư thì đang bị potay nghĩ mãi mà chẳng biết làm cách nào. Cụ thể như sau, hiện em có một sheet chứa CSDL về định mức ( gồm nhiều các loại hạng mục kèm mã hiệu của các hạng mục đó), và khi phân tích vật tư em chỉ cần dùng một vài mã hiệu ở bên sheet PTVT. em muốn khi mình gõ mã hiệu bên Sheet PTVT Excel thì tự động dò tìm bên sheet DM mã hiệu và các hạng mục. em rất mong được các sư huy giúp đỡ, em xin chân thành cảm ơn.
Nhấp chuột vào đây để mở rộng...
Lúc trước tôi có xây dựng hàm JoinSpec với yêu cầu gần tương tự như yêu cầu này ---> Giờ sửa lại tí là xài thôi:
PHP: 
Function FindSpec(ID As String, SrcRng As Range, Col_Index As Long)
  Dim Clls As Range, Temp
  With CreateObject("Scripting.Dictionary")
    For Each Clls In SrcRng.Resize(, 1)
      If Clls <> "" Then Temp = Clls.Value
      If Clls <> "" And Not .Exists(Clls.Value) Then
        .Add Clls.Value, Clls(, Col_Index).Value
      ElseIf Clls(, Col_Index) <> "" Then
        .Item(Temp) = .Item(Temp) & vbBack & Clls(, Col_Index).Value
      End If
    Next
    FindSpec = Split(.Item(ID), vbBack)
  End With
End Function
PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Tmp1, Tmp2, Tmp3, Func As WorksheetFunction
  On Error Resume Next
  Set Func = Application.WorksheetFunction
  If Not Intersect(Range("A3:A1000"), Target) Is Nothing Then
    With Sheets("DM")
      Tmp1 = Func.Transpose(FindSpec(Target.Value, .Range("DM"), 2))
      Tmp2 = Func.Transpose(FindSpec(Target.Value, .Range("DM"), 3))
      Tmp3 = Func.Transpose(FindSpec(Target.Value, .Range("DM"), 4))
    End With
    Target.Offset(, 1).Resize(UBound(Tmp1)).Value = Tmp1
    Target.Offset(, 2).Resize(UBound(Tmp2)).Value = Tmp2
    Target.Offset(, 3).Resize(UBound(Tmp3)).Value = Tmp3
  End If
End Sub
Trong đó Range("DM") chính là vùng dữ liệu tại sheet DM đã được định nghĩa trước trong Define name
Code vẫn chưa hoàn hảo lắm nhưng tạm dùng được
 

File đính kèm

adoonis đã viết:
Kính chào các sư huynh em đang tính tự lập một File Dự Toán bằng Excel, nhưng đến bước phân tích vật tư thì đang bị potay nghĩ mãi mà chẳng biết làm cách nào. Cụ thể như sau, hiện em có một sheet chứa CSDL về định mức ( gồm nhiều các loại hạng mục kèm mã hiệu của các hạng mục đó), và khi phân tích vật tư em chỉ cần dùng một vài mã hiệu ở bên sheet PTVT. em muốn khi mình gõ mã hiệu bên Sheet PTVT Excel thì tự động dò tìm bên sheet DM mã hiệu và các hạng mục. em rất mong được các sư huy giúp đỡ, em xin chân thành cảm ơn.
Nhấp chuột vào đây để mở rộng...

Bạn thử củ khoai này xem có được không ?
ở cột tên công việc có ô vuông màu trắng con con khi bạn tích dấu kiểm vào ô này thì bảng tính mới có tác dụng nhưng phải Lưu ý: khi chèn hoặc rút dòng thì bạn phải xóa dấu kiểm đi kẻo nó gây ra tác dụng phụ không mong muốn. Nếu bạn muốn chọn mã hiệu từ List thì kích đúp chuột vào ô bên cột mã hiệu, nếu ô đó là ô trống thì sẽ xuất hiện mũi tên xổ xuống (nếu bạn muốn sửa ô đã có mã hiệu thì bạn phải xóa dữ liệu trong ô đó rồi mới kích đúp chuột). Bạn muốn bảng dự toán định dạng kiểu nào (Font, nền, đường kẻ) thì bạn phải định dạng ngay từ bảng DM.
 

File đính kèm

Lần chỉnh sửa cuối:
ndu96081631 đã viết:
Lúc trước tôi có xây dựng hàm JoinSpec với yêu cầu gần tương tự như yêu cầu này ---> Giờ sửa lại tí là xài thôi:
PHP: 
Function FindSpec(ID As String, SrcRng As Range, Col_Index As Long)
  Dim Clls As Range, Temp
  With CreateObject("Scripting.Dictionary")
    For Each Clls In SrcRng.Resize(, 1)
      If Clls <> "" Then Temp = Clls.Value
      If Clls <> "" And Not .Exists(Clls.Value) Then
        .Add Clls.Value, Clls(, Col_Index).Value
      ElseIf Clls(, Col_Index) <> "" Then
        .Item(Temp) = .Item(Temp) & vbBack & Clls(, Col_Index).Value
      End If
    Next
    FindSpec = Split(.Item(ID), vbBack)
  End With
End Function
PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Tmp1, Tmp2, Tmp3, Func As WorksheetFunction
  On Error Resume Next
  Set Func = Application.WorksheetFunction
  If Not Intersect(Range("A3:A1000"), Target) Is Nothing Then
    With Sheets("DM")
      Tmp1 = Func.Transpose(FindSpec(Target.Value, .Range("DM"), 2))
      Tmp2 = Func.Transpose(FindSpec(Target.Value, .Range("DM"), 3))
      Tmp3 = Func.Transpose(FindSpec(Target.Value, .Range("DM"), 4))
    End With
    Target.Offset(, 1).Resize(UBound(Tmp1)).Value = Tmp1
    Target.Offset(, 2).Resize(UBound(Tmp2)).Value = Tmp2
    Target.Offset(, 3).Resize(UBound(Tmp3)).Value = Tmp3
  End If
End Sub
Trong đó Range("DM") chính là vùng dữ liệu tại sheet DM đã được định nghĩa trước trong Define name
Code vẫn chưa hoàn hảo lắm nhưng tạm dùng được
Nhấp chuột vào đây để mở rộng...
cảm ơn bác rất nhiều , rất tuyệt, nhưng em lai không biết viết code nên xin phép bác em dùng nguyên code cua bác nha. thanks
 
Trung Chinh đã viết:
Bạn thử củ khoai này xem có được không ?
ở cột tên công việc có ô vuông màu trắng con con khi bạn tích dấu kiểm vào ô này thì bảng tính mới có tác dụng nhưng phải Lưu ý: khi chèn hoặc rút dòng thì bạn phải xóa dấu kiểm đi kẻo nó gây ra tác dụng phụ không mong muốn. Nếu bạn muốn chọn mã hiệu từ List thì kích đúp chuột vào ô bên cột mã hiệu, nếu ô đó là ô trống thì sẽ xuất hiện mũi tên xổ xuống (nếu bạn muốn sửa ô đã có mã hiệu thì bạn phải xóa dữ liệu trong ô đó rồi mới kích đúp chuột). Bạn muốn bảng dự toán định dạng kiểu nào (Font, nền, đường kẻ) thì bạn phải định dạng ngay từ bảng DM.
Nhấp chuột vào đây để mở rộng...
Rất cảm ơn các bác đã nhiệt tình giúp đỡ, File của bác cũng rất tuyệt, em đang xem file, e mong tiếp tục nhận được sự giúp đỡ của bác cũng như các thành viên khác trong diễn dàn. Thanks
 
ndu96081631 đã viết:
Lúc trước tôi có xây dựng hàm JoinSpec với yêu cầu gần tương tự như yêu cầu này ---> Giờ sửa lại tí là xài thôi:
PHP: 
Function FindSpec(ID As String, SrcRng As Range, Col_Index As Long)
  Dim Clls As Range, Temp
  With CreateObject("Scripting.Dictionary")
    For Each Clls In SrcRng.Resize(, 1)
      If Clls <> "" Then Temp = Clls.Value
      If Clls <> "" And Not .Exists(Clls.Value) Then
        .Add Clls.Value, Clls(, Col_Index).Value
      ElseIf Clls(, Col_Index) <> "" Then
        .Item(Temp) = .Item(Temp) & vbBack & Clls(, Col_Index).Value
      End If
    Next
    FindSpec = Split(.Item(ID), vbBack)
  End With
End Function
PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Tmp1, Tmp2, Tmp3, Func As WorksheetFunction
  On Error Resume Next
  Set Func = Application.WorksheetFunction
  If Not Intersect(Range("A3:A1000"), Target) Is Nothing Then
    With Sheets("DM")
      Tmp1 = Func.Transpose(FindSpec(Target.Value, .Range("DM"), 2))
      Tmp2 = Func.Transpose(FindSpec(Target.Value, .Range("DM"), 3))
      Tmp3 = Func.Transpose(FindSpec(Target.Value, .Range("DM"), 4))
    End With
    Target.Offset(, 1).Resize(UBound(Tmp1)).Value = Tmp1
    Target.Offset(, 2).Resize(UBound(Tmp2)).Value = Tmp2
    Target.Offset(, 3).Resize(UBound(Tmp3)).Value = Tmp3
  End If
End Sub
Trong đó Range("DM") chính là vùng dữ liệu tại sheet DM đã được định nghĩa trước trong Define name
Code vẫn chưa hoàn hảo lắm nhưng tạm dùng được
Nhấp chuột vào đây để mở rộng...

Cám ơn thầy về đoạn code trên. Không hiểu sao em test trên máy em thì có định mức đúng, có định mức sai. cụ thể là nó lặp lại nguyên cả một đinh mức đó nhưng dòng cuối cùng không có dữ liệu của cột thứ 4(cột số lượng của đinh mức). em test cái AF.14324 thì đúng nhưng sang cái AF.81111, AE.15215... thì thấy hiện tượng trên. Mong thầy và các bạn test lại thử giùm em vì em cũng đang rất cần cái này. Hay là tạii máy em nhỉ(Win 7, Off 2003)
Cám ơn thầy nhiều
Chúc thầy luôn vui, khỏe và có nhiều bài viết hay cho bọn em học tập
Thân mến
 
ThanhPhương đã viết:
Cám ơn thầy về đoạn code trên. Không hiểu sao em test trên máy em thì có định mức đúng, có định mức sai. cụ thể là nó lặp lại nguyên cả một đinh mức đó nhưng dòng cuối cùng không có dữ liệu của cột thứ 4(cột số lượng của đinh mức). em test cái AF.14324 thì đúng nhưng sang cái AF.81111, AE.15215... thì thấy hiện tượng trên. Mong thầy và các bạn test lại thử giùm em vì em cũng đang rất cần cái này. Hay là tạii máy em nhỉ(Win 7, Off 2003)
Cám ơn thầy nhiều
Chúc thầy luôn vui, khỏe và có nhiều bài viết hay cho bọn em học tập
Thân mến
Nhấp chuột vào đây để mở rộng...
Nguyên nhân là vì tại Sheet DM của bạn có dữ liệu trùng ---> Cụ dòng 61 trùng dòng 163, dòng 87 trùng dòng 213... ---> Kiểm tra và xóa dữ liệu trùng nhé (có thể dùng COUNTIF để kiểm tra)
 
Anh ơi, em cảm ơn anh, em thấy file này rất tốt, nhưng em làm thử, mỗi lần chỉ nhập được 1 MH, chứ nó không tự nhận diện mã mà tự nhảy ra, nếu copy 1 lọat mã , thì mã sau sẽ chép đè lên mã trước, anh có cách nào sửa được không anh.
 
Khui lại cái cũ tí nhé bác ndu96081631 !! ^^

ndu96081631 đã viết:
Lúc trước tôi có xây dựng hàm JoinSpec với yêu cầu gần tương tự như yêu cầu này ---> Giờ sửa lại tí là xài thôi:
PHP: 
Function FindSpec(ID As String, SrcRng As Range, Col_Index As Long)
  Dim Clls As Range, Temp
  With CreateObject("Scripting.Dictionary")
    For Each Clls In SrcRng.Resize(, 1)
      If Clls <> "" Then Temp = Clls.Value
      If Clls <> "" And Not .Exists(Clls.Value) Then
        .Add Clls.Value, Clls(, Col_Index).Value
      ElseIf Clls(, Col_Index) <> "" Then
        .Item(Temp) = .Item(Temp) & vbBack & Clls(, Col_Index).Value
      End If
    Next
    FindSpec = Split(.Item(ID), vbBack)
  End With
End Function
PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Tmp1, Tmp2, Tmp3, Func As WorksheetFunction
  On Error Resume Next
  Set Func = Application.WorksheetFunction
  If Not Intersect(Range("A3:A1000"), Target) Is Nothing Then
    With Sheets("DM")
      Tmp1 = Func.Transpose(FindSpec(Target.Value, .Range("DM"), 2))
      Tmp2 = Func.Transpose(FindSpec(Target.Value, .Range("DM"), 3))
      Tmp3 = Func.Transpose(FindSpec(Target.Value, .Range("DM"), 4))
    End With
    Target.Offset(, 1).Resize(UBound(Tmp1)).Value = Tmp1
    Target.Offset(, 2).Resize(UBound(Tmp2)).Value = Tmp2
    Target.Offset(, 3).Resize(UBound(Tmp3)).Value = Tmp3
  End If
End Sub
Nhấp chuột vào đây để mở rộng...

Mình thấy code của bác ndu9608131 rất hay, bây giờ mình muốn tham khảo chỉ giáo của bác:
Bác đưa cái thủ tục duyệt dữ liệu của bác vào Worksheet, vì vậy mọi thao tác trong sheet bác đặt code đều thực hiện thủ tục đó. Có cách nào để thêm vào 1 popupMenu, hoặc 1 biểu tượng control để kiểm soát không. Nghĩa là chỉ khi nào popupMenu (hoặc điều khiển) đó chạy, thì mới thực hiện thủ tục của bác không. Còn bình thường thì vẫn nhập bình thường (mặc dù Cell nhập có mã hiệu trùng cũng sao).

Cảm ơn.
Thân. Mong nhận được hồi âm.
 
vba_gpe đã viết:
Mình thấy code của bác ndu9608131 rất hay, bây giờ mình muốn tham khảo chỉ giáo của bác:
Bác đưa cái thủ tục duyệt dữ liệu của bác vào Worksheet, vì vậy mọi thao tác trong sheet bác đặt code đều thực hiện thủ tục đó. Có cách nào để thêm vào 1 popupMenu, hoặc 1 biểu tượng control để kiểm soát không. Nghĩa là chỉ khi nào popupMenu (hoặc điều khiển) đó chạy, thì mới thực hiện thủ tục của bác không. Còn bình thường thì vẫn nhập bình thường (mặc dù Cell nhập có mã hiệu trùng cũng sao).

Cảm ơn.
Thân. Mong nhận được hồi âm.
Nhấp chuột vào đây để mở rộng...
Chổ màu đỏ không đúng à nha, vì tôi có đoạn này:
Mã: 
If Not Intersect(Range("A3:A1000"), Target) Is Nothing Then
Nên code chỉ hoạt động khi bạn nhập gì đó trong vùng A3:A1000 mà thôi ---> Nhập liệu ngoài vùng ấy thoải mái
Bạn muốn điều kiện code hoạt động thế nào thì cứ sửa đoạn IF này theo điều kiện của bạn
 
ndu96081631 đã viết:
Bạn muốn điều kiện code hoạt động thế nào thì cứ sửa đoạn IF này theo điều kiện của bạn
Nhấp chuột vào đây để mở rộng...
Mình cũng chưa biết VB nhiều, mình thử làm theo ý của anh Ndu96081631 nói nhưng không biết phải khai báo như thế nào vì cái Private sub Worksheet_Change sử dung tham số truyền vào là biến "Target", Mình thử viết mà không được, Up lên nhờ anh xem thế nào.
Ý mình là: Click vào cái Command Button thì sẽ có 2 tùy chọn, 1 là chạy cái code của anh, 2 là không cho chạy. Không cho chạy ở đây có nghĩa là dù nhập vào vùng nào đi nữa (Không kể A3:A1000) thì vẫn không thực hiện code của anh.

Mình có gừi file, nhờ anh xem giúp nhé. (Cái Control ngoài nhé anh).
Thân chào anh.
 

File đính kèm

nguoikemcoi đã viết:
Mình cũng chưa biết VB nhiều, mình thử làm theo ý của anh Ndu96081631 nói nhưng không biết phải khai báo như thế nào vì cái Private sub Worksheet_Change sử dung tham số truyền vào là biến "Target", Mình thử viết mà không được, Up lên nhờ anh xem thế nào.
Ý mình là: Click vào cái Command Button thì sẽ có 2 tùy chọn, 1 là chạy cái code của anh, 2 là không cho chạy. Không cho chạy ở đây có nghĩa là dù nhập vào vùng nào đi nữa (Không kể A3:A1000) thì vẫn không thực hiện code của anh.

Mình có gừi file, nhờ anh xem giúp nhé. (Cái Control ngoài nhé anh).
Thân chào anh.
Nhấp chuột vào đây để mở rộng...
UserForm của bạn tôi thiết kế lại thế này:

untitled.JPG

Trong Module2, tôi khai báo 1 biến Check dạng Public
PHP: 
Public Check As Boolean
Code trong UserForm:
PHP: 
Private Sub CheckBox1_Click()
  CheckBox1.Caption = IIf(CheckBox1, "No Run", "Run")
End Sub
PHP: 
Private Sub CmdOK_Click()
  Check = CheckBox1.Value
  Unload Me
End Sub
Sự kiện Change tôi sửa lại thế này
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Tmp1, Tmp2, Tmp3, Func As WorksheetFunction
  On Error Resume Next
  Set Func = Application.WorksheetFunction
  [B]If Not Intersect(Range("A3:A1000"), Target) Is Nothing [COLOR=red]And Check [/COLOR]Then[/B]
    With Sheets("DM")
      Tmp1 = Func.Transpose(FindSpec(Target.Value, .Range("DM"), 2))
      Tmp2 = Func.Transpose(FindSpec(Target.Value, .Range("DM"), 3))
      Tmp3 = Func.Transpose(FindSpec(Target.Value, .Range("DM"), 4))
    End With
    Target.Offset(, 1).Resize(UBound(Tmp1)).Value = Tmp1
    Target.Offset(, 2).Resize(UBound(Tmp2)).Value = Tmp2
    Target.Offset(, 3).Resize(UBound(Tmp3)).Value = Tmp3
  End If
End Sub
 

File đính kèm

Trong file của ndu có hàm này:
Mã: 
Function FindSpec(ID As String, SrcRng As Range, Col_Index As Long)
    Dim Clls As Range, Temp
    With CreateObject("Scripting.Dictionary")
        For Each Clls In SrcRng.Resize(, 1)
            If Clls <> "" Then Temp = Clls.Value
            If Clls <> "" And Not .Exists(Clls.Value) Then
                .Add Clls.Value, Clls(, Col_Index).Value
            ElseIf Clls(, Col_Index) <> "" Then
                .Item(Temp) = .Item(Temp) & vbBack & Clls(, Col_Index).Value
            End If
        Next
        FindSpec = Split(.Item(ID), vbBack)
    End With
End Function
Nhờ các Bạn giải thích để mình hiểu và tùy biến. Cám ơn các Bạn!
 
ndu96081631 đã viết:
UserForm của bạn tôi thiết kế lại thế này:

View attachment 60290

Trong Module2, tôi khai báo 1 biến Check dạng Public
PHP: 
Public Check As Boolean
Code trong UserForm:
PHP: 
Private Sub CheckBox1_Click()
  CheckBox1.Caption = IIf(CheckBox1, "No Run", "Run")
End Sub
PHP: 
Private Sub CmdOK_Click()
  Check = CheckBox1.Value
  Unload Me
End Sub
Sự kiện Change tôi sửa lại thế này
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Tmp1, Tmp2, Tmp3, Func As WorksheetFunction
  On Error Resume Next
  Set Func = Application.WorksheetFunction
  [B]If Not Intersect(Range("A3:A1000"), Target) Is Nothing [COLOR=red]And Check [/COLOR]Then[/B]
    With Sheets("DM")
      Tmp1 = Func.Transpose(FindSpec(Target.Value, .Range("DM"), 2))
      Tmp2 = Func.Transpose(FindSpec(Target.Value, .Range("DM"), 3))
      Tmp3 = Func.Transpose(FindSpec(Target.Value, .Range("DM"), 4))
    End With
    Target.Offset(, 1).Resize(UBound(Tmp1)).Value = Tmp1
    Target.Offset(, 2).Resize(UBound(Tmp2)).Value = Tmp2
    Target.Offset(, 3).Resize(UBound(Tmp3)).Value = Tmp3
  End If
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn anh nhé. Code ngắn nhưng hiệu quả vô cùng. Thực sự với sự hiểu biết VB của mình, các hàm anh viết trong file chắc chưa hiểu nổi. Vì vậy chỉ biết áp dụng.
Mình muốn nhờ anh chỉ giáo thêm vấn đề này. Nếu trong file đó, mình chèn thêm 1 sheet" DT". Thêm vào 1 cột là :stt vào trong sheet ("PTVT"). Như vậy, có cách nào để khi nhập mã hiệu ở bên Sheet "DT", Sheet PTVT sẽ tự động chèn cái tên công việc ứng với mã hiệu đó vào không?
Tại Sheet DT, không có phần chi tiết vật tư của từng công việc, mà chỉ có tên công việc. Phần chi tiết vật tư chỉ có ở bênh sheet PTVT ứng với tên và STT được nhập.

Thân. Nếu anh rảnh rổi thì xem giúp. Cảm ơn.
Mình có gửi file đính kèm.
 

File đính kèm

ndu96081631 đã viết:
Lúc trước tôi có xây dựng hàm JoinSpec với yêu cầu gần tương tự như yêu cầu này ---> Giờ sửa lại tí là xài thôi:
PHP: 
Function FindSpec(ID As String, SrcRng As Range, Col_Index As Long)
Dim Clls As Range, Temp
With CreateObject("Scripting.Dictionary")
For Each Clls In SrcRng.Resize(, 1)
If Clls <> "" Then Temp = Clls.Value
If Clls <> "" And Not .Exists(Clls.Value) Then
.Add Clls.Value, Clls(, Col_Index).Value
ElseIf Clls(, Col_Index) <> "" Then
.Item(Temp) = .Item(Temp) & vbBack & Clls(, Col_Index).Value
End If
Next
FindSpec = Split(.Item(ID), vbBack)
End With
End Function
PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Tmp1, Tmp2, Tmp3, Func As WorksheetFunction
On Error Resume Next
Set Func = Application.WorksheetFunction
If Not Intersect(Range("A3:A1000"), Target) Is Nothing Then
With Sheets("DM")
Tmp1 = Func.Transpose(FindSpec(Target.Value, .Range("DM"), 2))
Tmp2 = Func.Transpose(FindSpec(Target.Value, .Range("DM"), 3))
Tmp3 = Func.Transpose(FindSpec(Target.Value, .Range("DM"), 4))
End With
Target.Offset(, 1).Resize(UBound(Tmp1)).Value = Tmp1
Target.Offset(, 2).Resize(UBound(Tmp2)).Value = Tmp2
Target.Offset(, 3).Resize(UBound(Tmp3)).Value = Tmp3
End If
End Sub
Trong đó Range("DM") chính là vùng dữ liệu tại sheet DM đã được định nghĩa trước trong Define name
Code vẫn chưa hoàn hảo lắm nhưng tạm dùng được
Nhấp chuột vào đây để mở rộng...
Hàm này dùng truy xuất dữ liệu rất nhanh gọn, tuy nhiên nếu dữ liệu là các con số thập phân thì thỉnh thoảng nó tự động biến dấu thập phân thành dấu cách, ví dụ 1,333 sẽ bị biến thành 1.333, còn đa phần thì đúng. Vậy nên kết quả tính bị sai.
Mình thử thay thế câu: NewArr = Split(.Item(ID), vbBack)
thành:
.Item(ID) = Replace(.Item(ID), ",", ".")
NewArr = Split(.Item(ID), vbBack)
thì cột chứa số đúng nhưng cột text bị sai (hàm Vlooup khhông nhận được text này)
Nhờ các Bạn cho giải pháp!
 
ndu96081631 đã viết:
PHP: 
Function FindSpec(ID As String, SrcRng As Range, Col_Index As Long)
  Dim Clls As Range, Temp
  With CreateObject("Scripting.Dictionary")
    For Each Clls In SrcRng.Resize(, 1)
      If Clls <> "" Then Temp = Clls.Value
      If Clls <> "" And Not .Exists(Clls.Value) Then
        .Add Clls.Value, Clls(, Col_Index).Value
      ElseIf Clls(, Col_Index) <> "" Then
        .Item(Temp) = .Item(Temp) & vbBack & Clls(, Col_Index).Value
      End If
    Next
    FindSpec = Split(.Item(ID), vbBack)
  End With
End Function
PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Tmp1, Tmp2, Tmp3, Func As WorksheetFunction
  On Error Resume Next
  Set Func = Application.WorksheetFunction
  If Not Intersect(Range("A3:A1000"), Target) Is Nothing Then
    With Sheets("DM")
      Tmp1 = Func.Transpose(FindSpec(Target.Value, .Range("DM"), 2))
      Tmp2 = Func.Transpose(FindSpec(Target.Value, .Range("DM"), 3))
      Tmp3 = Func.Transpose(FindSpec(Target.Value, .Range("DM"), 4))
    End With
    Target.Offset(, 1).Resize(UBound(Tmp1)).Value = Tmp1
    Target.Offset(, 2).Resize(UBound(Tmp2)).Value = Tmp2
    Target.Offset(, 3).Resize(UBound(Tmp3)).Value = Tmp3
  End If
End Sub
Nhấp chuột vào đây để mở rộng...
Gửi anh ndu96081631
Về đoạn code của hàm FindSpec: (Em muốn bổ sung để anh hoàn thiện giúp - Không có ý gì khác).
-1: Tại Sheet: DM, trong 1 công tác bất kỳ AD.11222 (có đầy đủ 3 loại chi phí VL,NC,MTC) em chèn thêm 3 hàng : Vật liệu, Nhân công, Máy thi công như trong file em gửi. Khi qua Sheet PTVT, run thì tại 2 cột C,D bị nhầm vị trí.
Em không biết lý do này tại sao lại như vậy. Em thử khi đưa số liệu vào 2 đầu của các ô Vật liệu, nhân công, máy thi công thì nó sắp xếp đúng.
- 2: Trong Sheet: PTVT, Giữa 2 mã hiệu đã có, em chèn thêm 1 mã hiệu mới. Khi run thì giá trị của mã hiệu mới này đè lên mã hiệu cũ. Có cách nào mình làm nó tự động chèn thêm số dòng đúng bằng số dòng mà nó tìm thấy mã hiệu đó bên bảng DM không anh?
Gửi Anh Trungchinh.
-3. Trong đoạn code của Anh: khi chạy thì sẽ giữ lại toàn bộ format của cell gốc. Em xin nhờ anh chỉ giúp em phần nào trong code nói về khoảng đó:
PHP: 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Cancel = 1
    If Target = "" Then
        With Target.Validation
            .Delete
            .Add Type:=xlValidateList, Formula1:="=MHDM"
        End With
    End If
End Sub
'--------------------------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
On Error GoTo Thoat
If [a1] = False Then GoTo Thoat
If Not Intersect(Target, [b:b]) Is Nothing Then
        With Sheets("DM")
            Rd = .[b:b].Find(Target, LookAt:=1).Address
            Rc = .Range(Rd).End(4).Offset(-1).Address
            Tim = .Range(Rd, Rc).Resize(, 4).Address            '- Ham Tim này là mình tự đặt hay là có sẳng trong VB vậy anh. 
            .Range(Tim).Copy Target
            Target.Validation.Delete
        End With
    End If
Em chỉ muốn học hỏi được nhiều. Cảm ơn các anh.
Mong nhận được hồi âm
Thân ái.
 
Lần chỉnh sửa cuối:
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

Thanh271188
Tìm giá trị xuất hiện bất kì (không phải giá trị đầu, cuối) trong excel
    • Cười
Trả lời
4
Đọc
170
Duy Tùng 9x
Duy Tùng 9x
H
Xin viết dùng mã vba thay thế cho hàm vlookup
    • Thích
12 13 14
Trả lời
264
Đọc
79K
VetMini
V
SA_DQ
  • Question Question
[Bài tập VBA cho người rỗi rảnh] Hãy viết 1 macro tìm ra 3 số nguyên tố liên tiếp
2
Trả lời
35
Đọc
703
VetMini
V
Nauduong
Cách chuyển định dạng từ PDF sang Image
Trả lời
4
Đọc
115
Châu Bá Thông
Châu Bá Thông
minhduongct
  • Question Question
Viết code VBA thay cho dùng hàm vlookup
Trả lời
5
Đọc
1K
Hoàng Tuấn 868
H
P
Các Bác cho e hỏi làm thế nào để ẩn công thức trên GOOGLE SHEET với ạ?
2
Trả lời
22
Đọc
18K
yeudoi
yeudoi
T
Định dạng cột dữ liệu trong sql
Trả lời
5
Đọc
116
ptm0412
ptm0412
L
  • Question Question
[Hlep] Xóa ảnh theo tên và kích thước
Trả lời
8
Đọc
180
Luong24
L
Xoainon3005
Xin file mẫu kế hoạch sản xuất theo tháng ngành động cơ
Trả lời
0
Đọc
82
Xoainon3005
Xoainon3005
A
Tạo vé Loto bằng Excel
Trả lời
19
Đọc
23K
vinhquang14292
vinhquang14292
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
14 15 16
Trả lời
308
Đọc
22K
CheezeTube
CheezeTube
HeSanbi
  • Đã giải quyết
LocalizeXL v1.73 - Làm nổi bật ô đang chọn và cuộn trang tự động
    • Thích
    • Yêu thích
2 3 4
Trả lời
74
Đọc
10K
vn72259
V
H
Vì sao trong khi cộng và khi sum lại hiển thị sai
Trả lời
15
Đọc
57K
hieung99
hieung99
T
Nhờ hỗ trợ hàm SUMIF không phân biệt được các ký tự "0" trước một số trong chuỗi
Trả lời
3
Đọc
209
tan10ckn
T
huuthang_bd
Add-in DeleteVirusMacro - Xóa và ngăn chặn virus macro
    • Thích
    • Yêu thích
    • Chấp nhận
2 3
Trả lời
46
Đọc
14K
tuantran203
T
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
260
Đọc
27K
hoangtuan.net
hoangtuan.net
HeSanbi
  • Đã giải quyết
WeatherXL - Ứng dụng lấy dữ liệu Thời tiết siêu nhanh (*15/01/2024)
    • Thích
    • Yêu thích
3 4 5
Trả lời
88
Đọc
19K
vc_đi chơi
vc_đi chơi
L
[Help] tự động lấy dữ liệu cổ phiếu từ vietstock về file excel
    • Thích
Trả lời
3
Đọc
877
ketoan113
K
N
Tách chuỗi và tìm kiếm theo dữ liệu gần đúng trong chuỗi ký tự
Trả lời
8
Đọc
214
Ngocminh19
N
Mr.hieudoanxd
  • Question Question
[Cần hướng dẫn] Về lập trình Viết Function với Settimer và Killtimer
    • Thích
Trả lời
8
Đọc
363
nguyendang95
N
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
Chúc mừng năm mới Ất Tỵ 2025
Back
Top Bottom