Tham chiếu dữ liệu từ file đóng VBA

Liên hệ QC
LamNA

LamNA

Thành viên tích cực
Tham gia
3/6/14
Bài viết
897
Được thích
720
Giới tính
Nam
Nghề nghiệp
Quản Lý Cửa Hàng
Chào anh chị GPE
Nhằm tối ưu tiết kiệm dung lượng báo cáo file excel nên em có ý tưởng sẽ xuất sheet "Data_sp" từ file "test" ra riêng lẻ.
Giờ em muốn tham chiếu dữ liệu sẽ lấy từ file "DATA_SP" vào sheet "KQ"
Nhờ anh chị hỗ trợ chỉnh sửa lại code như file đính kèm.
Em cám ơn
 

File đính kèm

  • TEST.rar
    773.7 KB · Đọc: 16
Sắp xếp theo thời gian sắp xếp theo bầu chọn
LamNA đã viết:
Chào anh chị GPE
Nhằm tối ưu tiết kiệm dung lượng báo cáo file excel nên em có ý tưởng sẽ xuất sheet "Data_sp" từ file "test" ra riêng lẻ.
Giờ em muốn tham chiếu dữ liệu sẽ lấy từ file "DATA_SP" vào sheet "KQ"
Nhờ anh chị hỗ trợ chỉnh sửa lại code như file đính kèm.
Em cám ơn
Nhấp chuột vào đây để mở rộng...
Có phải là lấy dữ liệu thỏa điều kiện của cột F không bạn?
 
Upvote 0
Hai Lúa Miền Tây đã viết:
Có phải là lấy dữ liệu thỏa điều kiện của cột F không bạn?
Nhấp chuột vào đây để mở rộng...
Dạ anh
Như trong file test thì anh copy mã từ cột F vào cột A2 thì code đã chạy từ sheet DATA_SP của file
Giờ em nhờ chỉnh sửa code sẽ không tham chiếu sheet DATA_SP mà tham chiếu lấy dữ liệu từ file "DATA_SP"
Em cám ơn
 
Upvote 0
LamNA đã viết:
Dạ anh
Như trong file test thì anh copy mã từ cột F vào cột A2 thì code đã chạy từ sheet DATA_SP của file
Giờ em nhờ chỉnh sửa code sẽ không tham chiếu sheet DATA_SP mà tham chiếu lấy dữ liệu từ file "DATA_SP"
Em cám ơn
Nhấp chuột vào đây để mở rộng...

Chạy code sau nhé
Mã: 
Sub LayDL_HLMT()
    With CreateObject("ADODB.Connection")
        .Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=Excel 12.0"
        Sheet2.Range("A2").CopyFromRecordset .Execute("select a.* from [EXCEL 12.0;Database=" & ThisWorkbook.Path & "\DATA_SP.xlsx].[DATA_SP$] a Inner join [KQ$] b ON a.[MÃ HÀNG]=b.[Copy vào A2] ")
    End With
    
End Sub
 

File đính kèm

  • LayDL_FileDong.rar
    602.4 KB · Đọc: 15
Upvote 0
Hai Lúa Miền Tây đã viết:
Chạy code sau nhé
Mã: 
Sub LayDL_HLMT()
    With CreateObject("ADODB.Connection")
        .Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=Excel 12.0"
        Sheet2.Range("A2").CopyFromRecordset .Execute("select a.* from [EXCEL 12.0;Database=" & ThisWorkbook.Path & "\DATA_SP.xlsx].[DATA_SP$] a Inner join [KQ$] b ON a.[MÃ HÀNG]=b.[Copy vào A2] ")
    End With
   
End Sub
Nhấp chuột vào đây để mở rộng...
Dạ anh hiểu nhầm
Mã cột F chỉ là ví dụ để anh gán vào A2 để chạy code thôi chứ không phải điều kiện
Thực tế em đang làm như Vlookup thay vì sẽ tham chiếu mã hàng từ cột A để lấy dữ liệu tương ứng từ sheet "DATA_SP".nay em muốn đổi tham chiếu sang file "DATA_SP" thay vì là Sheet trong file.
 

File đính kèm

  • Thamchieu.png
    Thamchieu.png
    38.7 KB · Đọc: 13
Upvote 0
LamNA đã viết:
Dạ anh hiểu nhầm
Mã cột F chỉ là ví dụ để anh gán vào A2 để chạy code thôi chứ không phải điều kiện
Thực tế em đang làm như Vlookup thay vì sẽ tham chiếu mã hàng từ cột A để lấy dữ liệu tương ứng từ sheet "DATA_SP".nay em muốn đổi tham chiếu sang file "DATA_SP" thay vì là Sheet trong file.
Nhấp chuột vào đây để mở rộng...
Vậy cái cột F đó thay = cột A trong sheet DATA_SP đúng không bạn?
 
Upvote 0

File đính kèm

  • TEST.rar
    775.1 KB · Đọc: 13
Upvote 0
LamNA đã viết:
Em xin diễn giải lại như trong file đính kèm, đại loại bỏ tham chiếu Vlookup dựa vào mã hàng từ A2 trở xuống tương ứng file "DATA" trong folder Test "DATA"
Nhấp chuột vào đây để mở rộng...
Bạn test code sau nhé

Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column = 1 Then
        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"""
            Target.Offset(, 1).CopyFromRecordset .Execute("select F2,F3,F4 from [DATA_SP$] where F1 like '" & Target.Value & "'")
        End With
    End If
End Sub
 
Upvote 0
Hai Lúa Miền Tây đã viết:
Bạn test code sau nhé

Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column = 1 Then
        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"""
            Target.Offset(, 1).CopyFromRecordset .Execute("select F2,F3,F4 from [DATA_SP$] where F1 like '" & Target.Value & "'")
        End With
    End If
End Sub
Nhấp chuột vào đây để mở rộng...
Em cám ơn anh đã hỗ trợ, em thêm như vậy code chạy tốt
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
  On Error Resume Next
With CreateObject("ADODB.Connection")
            .Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\DATA.xlsx;Extended Properties=""Excel 12.0;HDR=No"""
            
  Set wks = Sheets("DATA_SP")
  Set SrcRng = wks.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
 
Upvote 0
LamNA đã viết:
Em cám ơn anh đã hỗ trợ, em thêm như vậy code chạy tốt
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
  On Error Resume Next
With CreateObject("ADODB.Connection")
            .Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\DATA.xlsx;Extended Properties=""Excel 12.0;HDR=No"""
           
  Set wks = Sheets("DATA_SP")
  Set SrcRng = wks.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
Nhấp chuột vào đây để mở rộng...
Thử xóa sheet DATA_SP rồi chạy code :confused:
 
Upvote 0
LamNA đã viết:
À em quên nát luôn hehe
Em muốn tận dụng code cũ anh hỗ trợ giúp em với nhe
Nhấp chuột vào đây để mở rộng...
Nhập thử vào cột A để chạy code
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
Bài đã được tự động gộp:

LamNA đã viết:
À em quên nát luôn hehe
Em muốn tận dụng code cũ anh hỗ trợ giúp em với nhe
Nhấp chuột vào đây để mở rộng...
Nếu muốn trả về kết quả "Khac" thì chỉnh lại code
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim sRng As Range, Res(), S As Variant, iKey, 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
        iKey = sRng(i, 1).Value
        S = Dic.Item(iKey)
        If TypeName(S) = "Variant()" Then
          Res(i, 1) = S(0): Res(i, 2) = S(1): Res(i, 3) = S(2)
        ElseIf Len(iKey) > 0 Then
          Res(i, 1) = "Khac": Res(i, 2) = "Khac": Res(i, 3) = "Khac"
        End If
      Next i
      sRng.Offset(0, 1).Resize(, 3).Value = Res
    End If
  End If
  Application.EnableEvents = True
  Application.ScreenUpdating = True
End Sub
 

File đính kèm

  • test.xlsb
    15.9 KB · Đọc: 18
Lần chỉnh sửa cuối:
Upvote 0
VetMini đã viết:
Báo cáo thì nó chứa đủ dữ liệu mà nó cần báo cáo, không hơn không kém. Liên quan gì đến tối ưu tiết kiệm dung lượng?
Nhấp chuột vào đây để mở rộng...
Dạ thực tế data cần tham chiếu nó tới 9mb mà them dữ liệu để phân tích thì có thể lên tới 13mb nếu dùng kiểu này sẽ tiết kiệm được nhiều lắm anh
Bài đã được tự động gộp:

HieuCD đã viết:
Nhập thử vào cột A để chạy code
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
Bài đã được tự động gộp:


Nếu muốn trả về kết quả "Khac" thì chỉnh lại code
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim sRng As Range, Res(), S As Variant, iKey, 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
        iKey = sRng(i, 1).Value
        S = Dic.Item(iKey)
        If TypeName(S) = "Variant()" Then
          Res(i, 1) = S(0): Res(i, 2) = S(1): Res(i, 3) = S(2)
        ElseIf Len(iKey) > 0 Then
          Res(i, 1) = "Khac": Res(i, 2) = "Khac": Res(i, 3) = "Khac"
        End If
      Next i
      sRng.Offset(0, 1).Resize(, 3).Value = Res
    End If
  End If
  Application.EnableEvents = True
  Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Em cám ơn anh file ch
HieuCD đã viết:
Nhập thử vào cột A để chạy code
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
Bài đã được tự động gộp:


Nếu muốn trả về kết quả "Khac" thì chỉnh lại code
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim sRng As Range, Res(), S As Variant, iKey, 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
        iKey = sRng(i, 1).Value
        S = Dic.Item(iKey)
        If TypeName(S) = "Variant()" Then
          Res(i, 1) = S(0): Res(i, 2) = S(1): Res(i, 3) = S(2)
        ElseIf Len(iKey) > 0 Then
          Res(i, 1) = "Khac": Res(i, 2) = "Khac": Res(i, 3) = "Khac"
        End If
      Next i
      sRng.Offset(0, 1).Resize(, 3).Value = Res
    End If
  End If
  Application.EnableEvents = True
  Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Em cám ơn anh đã thành công
 
Lần chỉnh sửa cuối:
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

hongphuong1997
  • Question
Lấy ký tự trong chuỗi theo nhiều điều kiện
Trả lời
1
Đọc
57
Duy Tùng 9x
Duy Tùng 9x
A
[Cần Giúp] Excel nhiều người dùng cùng lúc
Trả lời
0
Đọc
1
anhphuong157
A
N
Hàm if, lọc dữ liệu trùng
Trả lời
7
Đọc
6K
HUONGHCKT
H
tby211
Lỗi 1004 vba khi tách file trắc nghiệm sang excel
Trả lời
1
Đọc
37
HUONGHCKT
H
T
di chuyển đến ô kết quả của hàm
2
Trả lời
21
Đọc
7K
hoangtuan.net
hoangtuan.net
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL

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

Back
Top Bottom