trích lọc dữ liệu theo điều kiện cách sử dụng như hàm Vlookup

Liên hệ QC
huonglien1901

huonglien1901

GPE là ngôi nhà thứ 2 của tôi!!!
Tham gia
17/4/16
Bài viết
2,701
Được thích
2,434
Giới tính
Nam
Nghề nghiệp
Nhân viên kỹ thuật in ấn
Em chào mọi người!

Em có vấn đề nhờ mọi người hỗ trợ.

Em muốn trích lọc dữ liệu dựa vào điều kiện mã hàng

em có sử dụng code nhưng nó báo lỗi ở dòng này!
PHP: 
.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & TenFileDuongDan & ";" & "Extended Properties=""Excel 8.0;HDR=No &"""
PHP: 
Option Explicit
Public Chk As Boolean, Dic As Object, aResult()
Sub Vlookup_DATA_SP()
Dim wks As Worksheet, SrcRng As Range, sArray
  Dim LR As Long, i As Long, n As Long, tmp
  Dim TenFileDuongDan As String
TenFileDuongDan = ThisWorkbook.Path & "\Data.xlsx"
  On Error Resume Next
With CreateObject("ADODB.Connection")
.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & TenFileDuongDan & ";" & "Extended Properties=""Excel 8.0;HDR=No &"""
  Set SrcRng = Sheets("DATA_SP").Range("A2:D60000")
  sArray = SrcRng.Value
  ReDim aResult(1 To UBound(sArray, 1), 1 To UBound(sArray, 2))
  Set Dic = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(sArray, 1)
    If CStr(sArray(i, 1)) <> "" Then
      tmp = sArray(i, 1)
      If Not Dic.exists(tmp) Then
        LR = LR + 1
        Dic.Add tmp, LR
        aResult(LR, 1) = tmp
        aResult(LR, 2) = sArray(i, 2) 'TEN SAN PHAM
        aResult(LR, 3) = sArray(i, 3) 'NGANH HANG
        aResult(LR, 4) = sArray(i, 4) 'HANG
      End If
    End If
  Next
End With
End Sub
Em nhờ mọi người hỗ trợ.
Khi em chạy code thì nó không hoạt động!

Em cảm ơn mọi người nhiều!
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
huonglien1901 đã viết:
Em chào mọi người!

Em có vấn đề nhờ mọi người hỗ trợ.

Em muốn trích lọc dữ liệu dựa vào điều kiện mã hàng

em có sử dụng code nhưng nó báo lỗi ở dòng này!
PHP: 
.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & TenFileDuongDan & ";" & "Extended Properties=""Excel 8.0;HDR=No &"""
PHP: 
Option Explicit
Public Chk As Boolean, Dic As Object, aResult()
Sub Vlookup_DATA_SP()
Dim wks As Worksheet, SrcRng As Range, sArray
  Dim LR As Long, i As Long, n As Long, tmp
  Dim TenFileDuongDan As String
TenFileDuongDan = ThisWorkbook.Path & "\Data.xlsx"
  On Error Resume Next
With CreateObject("ADODB.Connection")
.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & TenFileDuongDan & ";" & "Extended Properties=""Excel 8.0;HDR=No &"""
  Set SrcRng = Sheets("DATA_SP").Range("A2:D60000")
  sArray = SrcRng.Value
  ReDim aResult(1 To UBound(sArray, 1), 1 To UBound(sArray, 2))
  Set Dic = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(sArray, 1)
    If CStr(sArray(i, 1)) <> "" Then
      tmp = sArray(i, 1)
      If Not Dic.exists(tmp) Then
        LR = LR + 1
        Dic.Add tmp, LR
        aResult(LR, 1) = tmp
        aResult(LR, 2) = sArray(i, 2) 'TEN SAN PHAM
        aResult(LR, 3) = sArray(i, 3) 'NGANH HANG
        aResult(LR, 4) = sArray(i, 4) 'HANG
      End If
    End If
  Next
End With
End Sub
Em nhờ mọi người hỗ trợ.
Khi em chạy code thì nó không hoạt động!

Em cảm ơn mọi người nhiều!
Nhấp chuột vào đây để mở rộng...

Code này code tác dụng gì vậy bạn, nhìn code đấy nếu không lỗi thì cũng chỉ ghi dữ liệu vào mảng rồi không để làm gì cả thì phải?
 
Upvote 0
huonglien1901 đã viết:
Em chào mọi người!

Em có vấn đề nhờ mọi người hỗ trợ.

Em muốn trích lọc dữ liệu dựa vào điều kiện mã hàng

em có sử dụng code nhưng nó báo lỗi ở dòng này!
PHP: 
.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & TenFileDuongDan & ";" & "Extended Properties=""Excel 8.0;HDR=No &"""
PHP: 
Option Explicit
Public Chk As Boolean, Dic As Object, aResult()
Sub Vlookup_DATA_SP()
Dim wks As Worksheet, SrcRng As Range, sArray
  Dim LR As Long, i As Long, n As Long, tmp
  Dim TenFileDuongDan As String
TenFileDuongDan = ThisWorkbook.Path & "\Data.xlsx"
  On Error Resume Next
With CreateObject("ADODB.Connection")
.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & TenFileDuongDan & ";" & "Extended Properties=""Excel 8.0;HDR=No &"""
  Set SrcRng = Sheets("DATA_SP").Range("A2:D60000")
  sArray = SrcRng.Value
  ReDim aResult(1 To UBound(sArray, 1), 1 To UBound(sArray, 2))
  Set Dic = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(sArray, 1)
    If CStr(sArray(i, 1)) <> "" Then
      tmp = sArray(i, 1)
      If Not Dic.exists(tmp) Then
        LR = LR + 1
        Dic.Add tmp, LR
        aResult(LR, 1) = tmp
        aResult(LR, 2) = sArray(i, 2) 'TEN SAN PHAM
        aResult(LR, 3) = sArray(i, 3) 'NGANH HANG
        aResult(LR, 4) = sArray(i, 4) 'HANG
      End If
    End If
  Next
End With
End Sub
Em nhờ mọi người hỗ trợ.
Khi em chạy code thì nó không hoạt động!

Em cảm ơn mọi người nhiều!
Nhấp chuột vào đây để mở rộng...
Sửa lại đường dẫn DATA__SP.xlsx
Bài đã được tự động gộp:

Nguyễn Hoàng Oanh Thơ đã viết:
Code này code tác dụng gì vậy bạn, nhìn code đấy nếu không lỗi thì cũng chỉ ghi dữ liệu vào mảng rồi không để làm gì cả thì phải?
Nhấp chuột vào đây để mở rộng...
Cái này là lấy dữ liệu vlookup dữ liệu file đóng đó chị
 
Upvote 0
LamNA đã viết:
Sửa lại đường dẫn DATA__SP.xlsx
Bài đã được tự động gộp:


Cái này là lấy dữ liệu vlookup dữ liệu file đóng đó chị
Nhấp chuột vào đây để mở rộng...
Sửa lại mỗi chỗ đó chắc gì đã được ạ, hình như phải sửa lại cả câu lệnh "connection string" và những chỗ khác. ADO mình cũng không rõ.
 
Upvote 0
OT thử VBA kết nối ngon lành nhưng không thấy hiệu ứng kết quả trả về đâu cả. @@!
Mã: 
Option Explicit
Public Chk As Boolean, Dic As Object, aResult()
Sub Vlookup_DATA_SP()
    Dim wks As Worksheet, SrcRng As Range, sArray
    Dim LR As Long, i As Long, n As Long, tmp
    Dim TenFileDuongDan As String, destWB As Workbook, fileName As String
    fileName = "DATA_SP.xlsx"
    TenFileDuongDan = ThisWorkbook.Path & "\" & fileName
    'On Error Resume Next
    If bIsBookOpen(fileName) Then
        Set destWB = Workbooks(fileName)
    Else
        Set destWB = Workbooks.Open(TenFileDuongDan)
    End If
    Set SrcRng = destWB.Sheets("DATA_SP").Range("A2:D60000")
    sArray = SrcRng.Value
    ReDim aResult(1 To UBound(sArray, 1), 1 To UBound(sArray, 2))
    Set Dic = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(sArray, 1)
      If CStr(sArray(i, 1)) <> "" Then
        tmp = sArray(i, 1)
        If Not Dic.exists(tmp) Then
          LR = LR + 1
          Dic.Add tmp, LR
          aResult(LR, 1) = tmp
          aResult(LR, 2) = sArray(i, 2) 'TEN SAN PHAM
          aResult(LR, 3) = sArray(i, 3) 'NGANH HANG
          aResult(LR, 4) = sArray(i, 4) 'HANG
        End If
      End If
    Next
    destWB.Close False
End Sub
Function bIsBookOpen(ByRef szBookName As String) As Boolean
' Rob Bovey
    On Error Resume Next
    bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function
 
Upvote 0
Nguyễn Hoàng Oanh Thơ đã viết:
OT thử VBA kết nối ngon lành nhưng không thấy hiệu ứng kết quả trả về đâu cả. @@!
Mã: 
Option Explicit
Public Chk As Boolean, Dic As Object, aResult()
Sub Vlookup_DATA_SP()
    Dim wks As Worksheet, SrcRng As Range, sArray
    Dim LR As Long, i As Long, n As Long, tmp
    Dim TenFileDuongDan As String, destWB As Workbook, fileName As String
    fileName = "DATA_SP.xlsx"
    TenFileDuongDan = ThisWorkbook.Path & "\" & fileName
    'On Error Resume Next
    If bIsBookOpen(fileName) Then
        Set destWB = Workbooks(fileName)
    Else
        Set destWB = Workbooks.Open(TenFileDuongDan)
    End If
    Set SrcRng = destWB.Sheets("DATA_SP").Range("A2:D60000")
    sArray = SrcRng.Value
    ReDim aResult(1 To UBound(sArray, 1), 1 To UBound(sArray, 2))
    Set Dic = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(sArray, 1)
      If CStr(sArray(i, 1)) <> "" Then
        tmp = sArray(i, 1)
        If Not Dic.exists(tmp) Then
          LR = LR + 1
          Dic.Add tmp, LR
          aResult(LR, 1) = tmp
          aResult(LR, 2) = sArray(i, 2) 'TEN SAN PHAM
          aResult(LR, 3) = sArray(i, 3) 'NGANH HANG
          aResult(LR, 4) = sArray(i, 4) 'HANG
        End If
      End If
    Next
    destWB.Close False
End Sub
Function bIsBookOpen(ByRef szBookName As String) As Boolean
' Rob Bovey
    On Error Resume Next
    bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function
Nhấp chuột vào đây để mở rộng...
Bài này code bữa được hỗ trợ là thế này
Mã: 
Dim Dic As Object

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim sRng As Range, Res(), S As Variant, i As Long, sRow As Long

  Application.EnableEvents = False
  Application.ScreenUpdating = False
  Set sRng = Intersect(Range("A2:A600000"), Target)
  If Not sRng Is Nothing Then
    If Dic Is Nothing Then Call CreateDic
    If Not Dic Is Nothing Then
      sRow = sRng.Rows.Count
      ReDim Res(1 To sRow, 1 To 3)
      For i = 1 To sRow
        S = Dic.Item(sRng(i, 1).Value)
        If TypeName(S) = "Variant()" Then
          Res(i, 1) = S(0): Res(i, 2) = S(1): Res(i, 3) = S(2)
        End If
      Next i
      sRng.Offset(0, 1).Resize(, 3).Value = Res
    End If
  End If
  Application.EnableEvents = True
  Application.ScreenUpdating = True
End Sub

Private Sub CreateDic()
  Dim sArr As Variant, j As Long, k As Long, iKey

  On Error Resume Next
  With CreateObject("ADODB.Connection")
    .Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\DATA_SP.xlsx;Extended Properties=""Excel 12.0;HDR=No"""
    sArr = .Execute("select * from [DATA_SP$A2:D1000000] where f1 is not null").GetRows
  End With
  If Err.Number = 0 Then
    Set Dic = CreateObject("Scripting.Dictionary")
    For j = 0 To UBound(sArr, 2)
      iKey = sArr(0, j)
      If Len(iKey) > 0 Then
        If Not Dic.exists(iKey) Then
          Dic.Add iKey, Array(sArr(1, j), sArr(2, j), sArr(3, j))
        End If
      End If
    Next
  Else
    MsgBox ("Khong tìm thay File du lieu")
    On Error GoTo 0
  End If
End Sub
 

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.
Web KT

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

dinhnhat91
  • Question Question
VBA Lỗi runtime error 9 subscript out of range
Trả lời
4
Đọc
70
ongke0711
ongke0711
GPE-Trợ Lý
[GPE] TALK SHOW EXCEL TRONG SẢN XUẤT
    • Thích
Trả lời
1
Đọc
508
PhanTuHuong
PhanTuHuong
Việt Nguyễn 86
Excel hay bị tắt đột ngột và hiện trang trắng khi làm việc
Trả lời
0
Đọc
49
Việt Nguyễn 86
Việt Nguyễn 86
K
Mong giúp dữ liệu từ trang web sang excel
Trả lời
0
Đọc
49
khanhvinhdai1
K
T
Bảng tính trợ cấp tinh giản biên chế theo NĐ 108
    • Thích
Trả lời
3
Đọc
1K
trung_bhxh
T
T
Bảng tính trợ cấp theo Nghị định 178 và tính lương hưu
Trả lời
0
Đọc
76
trung_bhxh
T
L
Viết phần mềm đánh lô bằng Visual Basic
    • Thích
2 3
Trả lời
52
Đọc
103K
khanhvinhdai1
K
GPE-Trợ Lý
KHÓA HỌC BỨT PHÁ KỸ NĂNG EXCEL
    • Thích
    • Yêu thích
Trả lời
3
Đọc
1K
Skyler113
Skyler113
Mewwo98
Thay dấu ngăn cách sau chữ số hàng nghìn, hàng triệu, hàng tỷ trong Mail Merge
Trả lời
5
Đọc
108
ptm0412
ptm0412
Huyen9
Lỗi không mailings được.
Trả lời
3
Đọc
84
vanle33
vanle33
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
310
Đọc
23K
kunkoi9390
K
K
Có ai giúp mình lấy kết quả xổ số miền nam về file excel
Trả lời
0
Đọc
43
khanhvinhdai1
K
ptm0412
  • Question Question
Lấy dữ liệu web nhiều trang về file Excel bằng Power Query
    • Thích
Trả lời
5
Đọc
2K
ptm0412
ptm0412
H
Công thức tìm kết quả
Trả lời
11
Đọc
124
VetMini
V
V
Hàm dò tìm lấy giá trị của lần xuất hiện thứ n trong excel.
Trả lời
9
Đọc
1K
VetMini
V
N
Nhờ các anh chỉ chỉnh lỗi giúp em với ạ, em cảm ơn ạ.
Trả lời
3
Đọc
82
minhminh27
minhminh27
T
File quản lý thiết bị trong trường học!
Trả lời
4
Đọc
139
VetMini
V
Xoainon3005
Xin file mẫu kế hoạch sản xuất theo tháng ngành động cơ
Trả lời
1
Đọc
134
VetMini
V
Momominh
Sơ đồ hàng hóa trong Container
Trả lời
3
Đọc
135
VetMini
V
hungtin1997
  • Question Question
[Hỏi] Tạo Hyperlink đến ô chạy ngang theo cột
Trả lời
6
Đọc
420
A HOANG 620
A
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