Code Replace dữ liệu từ một File không mở vào 1 file khác có sheet được chỉ định (1 người xem)

[lulyen]

Nhờ các cao thủ GPE giúp tôi đoạn Code để làm sao không cần mở File nguồn mà vẫn có thể lấy dữ liệu ra và thay thế vào một sheet của file hiện hành.
Cụ thể: tôi có 2 file
File TTKH được trích xuất từ phần mềm chuyên ngành ra nó thay đổi liên tục theo từng khách hàng đến giao dịch.
File TTCHUNG là file cố định trong đó có 2 sheet để làm việc là: TTCHUNG và MAU BIEU.
Mong muốn của tôi là sử dụng một đoạn Code để lấy toàn bộ dữ liệu tại File TTKH thay thể vào Sheet TTCHUNG của File TTCHUNG.
Rất mong được sự quan tâm giúp đỡ của các thành viên GPE, Xin chân thành cảm ơn!

 

[ndu96081631]

Nhờ các cao thủ GPE giúp tôi đoạn Code để làm sao không cần mở File nguồn mà vẫn có thể lấy dữ liệu ra và thay thế vào một sheet của file hiện hành.
Cụ thể: tôi có 2 file
File TTKH được trích xuất từ phần mềm chuyên ngành ra nó thay đổi liên tục theo từng khách hàng đến giao dịch.
File TTCHUNG là file cố định trong đó có 2 sheet để làm việc là: TTCHUNG và MAU BIEU.
Mong muốn của tôi là sử dụng một đoạn Code để lấy toàn bộ dữ liệu tại File TTKH thay thể vào Sheet TTCHUNG của File TTCHUNG.
Rất mong được sự quan tâm giúp đỡ của các thành viên GPE, Xin chân thành cảm ơn!

- Dữ liệu chỉ có đúng 2 dòng thôi hả bạn? Nếu nó nhiều hơn thì ít ra bạn cũng đưa lên vài chục dòng chứ (cho dễ test)
- Bạn dùng từ thay thế, có nghĩa là ĐÈ lên dữ liệu cũ? (xóa cũ, ghi mới), đúng không?

 

[lulyen]

- Dữ liệu chỉ có đúng 2 dòng thôi hả bạn? Nếu nó nhiều hơn thì ít ra bạn cũng đưa lên vài chục dòng chứ (cho dễ test)
- Bạn dùng từ thay thế, có nghĩa là ĐÈ lên dữ liệu cũ? (xóa cũ, ghi mới), đúng không?

Vâng, dữ liệu chỉ có 2 dòng, và xóa cũ ghi mới thầy ạ!

 

[Hai Lúa Miền Tây]

Vâng, dữ liệu chỉ có 2 dòng, và xóa cũ ghi mới thầy ạ!

Chạy code sau:

[GPECODE=sql]Sub LayDL()
Dim lsSQL As String, cnn As Object, lrs As Object
Set cnn = CreateObject("ADODB.Connection")
Set lrs = CreateObject("ADODB.Recordset")
With cnn
.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.Path & _
"\TTKH-1.xls;Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"
.Open
End With
With lrs
.ActiveConnection = cnn
lsSQL = "SELECT * " & _
"FROM [TTKH$] "
.Open lsSQL
End With
With Sheets("TTCHUNG")
.[A2:H1000].ClearContents
.[A2].CopyFromRecordset lrs
End With
lrs.Close: Set lrs = Nothing
cnn.Close: Set cnn = Nothing

End Sub

[/GPECODE]
Lưu ý 2 file nằm chung 1 đường dẫn.

 

[lulyen]

Chạy code sau:

[/GPECODE]
Lưu ý 2 file nằm chung 1 đường dẫn.

Cảm ơn bác Hai Lúa, Xin hỏi thêm bác: Nếu để 2 file khác đường dẫn liệu có được không? Và File TTKH có thể đặt tên bất kỳ có được không?

 

[ndu96081631]

Vâng, dữ liệu chỉ có 2 dòng, và xóa cũ ghi mới thầy ạ!

Thế thì chỉ cần gõ công thức này vào cell A1 (của sheet TTCHUNG, file TTCHUNG.xls):

=TTKH.XLS!A1

Kéo fill sang phải và xuống dưới là được rồi
Nếu file nguồn khác đường dẫn thì sửa lại cho đúng. Thậm chí khi ta cố tình dời file nguồn sang nơi khác thì khi mở file đích lên, Excel sẽ hiện thông báo UPDATE LINK, Bấm vào Edit Link để cập nhật đường dẫn mới (nếu cần)

 

[lulyen]

Thế thì chỉ cần gõ công thức này vào cell A1 (của sheet TTCHUNG, file TTCHUNG.xls):

=TTKH.XLS!A1

Kéo fill sang phải và xuống dưới là được rồi
Nếu file nguồn khác đường dẫn thì sửa lại cho đúng. Thậm chí khi ta cố tình dời file nguồn sang nơi khác thì khi mở file đích lên, Excel sẽ hiện thông báo UPDATE LINK, Bấm vào Edit Link để cập nhật đường dẫn mới (nếu cần)

Cảm ơn Bác ndu, ý em là muốn xin Code để có thể đặt tên File TTKH thành một File có tên bất kỳ có cùng định dạng như nhau cơ ạ!

 

[ndu96081631]

Cảm ơn Bác ndu, ý em là muốn xin Code để có thể đặt tên File TTKH thành một File có tên bất kỳ có cùng định dạng như nhau cơ ạ!

Vậy thì code này chắc bạn biết dùng:

Function GetData(ByVal FileName As String, ByVal SheetName As String, ByVal RangeAddress As String, _
            ByVal HasTitle As Boolean, ByVal UseTitle As Boolean)
            
  Dim rsCon As Object, rsData As Object, cat As Object, tbl As Object
  Dim tmpArr, Arr()
  Dim szConnect As String, szSQL As String, tmp As String
  Dim lCount As Long, lR As Long, lC As Long, lVer As Long
  lVer = Val(Application.Version)
  Set rsCon = CreateObject("ADODB.Connection")
  Set rsData = CreateObject("ADODB.Recordset")
  Set cat = CreateObject("ADOX.Catalog")
  
  If lVer < 12 Then
    szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & FileName & ";" & _
                "Extended Properties=""Excel 8.0;HDR=" & IIf(HasTitle, "Yes", "No") & """;"
  Else
    szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FileName & ";" & _
                "Extended Properties=""Excel 12.0;HDR=" & IIf(HasTitle, "Yes", "No") & """;"
  End If
  If SheetName = "" Then
    Dim Dbs  As Object, db As Object
    Set Dbs = CreateObject("DAO.DBEngine." & IIf(lVer < 12, "36", "120"))
    Set db = Dbs.OpenDatabase(FileName, False, False, "Excel 8.0;")
    tmp = db.TableDefs(0).Name
    tmp = Replace(tmp, " ", "?")
    tmp = Replace(tmp, "'", " ")
    tmp = WorksheetFunction.Trim(tmp)
    tmp = Replace(tmp, " ", "'")
    tmp = Replace(tmp, "?", " ")
    SheetName = tmp
    db.Close
    Set Dbs = Nothing: Set db = Nothing
  End If
  If Right(SheetName, 1) <> "$" Then SheetName = SheetName & "$"
  rsCon.Open szConnect
  cat.ActiveConnection = rsCon
  
  szSQL = "SELECT * FROM [" & SheetName & RangeAddress & "];"
  rsData.Open szSQL, rsCon, 0, 1, 1
  tmpArr = rsData.GetRows
  ReDim Arr(UBound(tmpArr, 2) - UseTitle, UBound(tmpArr, 1) + 1)
  If UseTitle Then
    For lC = LBound(tmpArr, 1) To UBound(tmpArr, 1)
      Arr(0, lC) = rsData.Fields(lC).Name
    Next
  End If
  For lR = LBound(tmpArr, 2) To UBound(tmpArr, 2)
    For lC = LBound(tmpArr, 1) To UBound(tmpArr, 1)
      Arr(lR - UseTitle, lC) = tmpArr(lC, lR)
    Next
  Next
  rsData.Close: Set rsData = Nothing
  rsCon.Close: Set rsCon = Nothing
  GetData = Arr
End Function

Áp dụng:

Sub Main()
  Dim Arr
  Arr = GetData([COLOR=#ff0000]ThisWorkbook.Path & "\TTK.XLS"[/COLOR], "TTKH", "A1:I2", True, True)
  Range("A1:I2").Value = Arr
End Sub

Chổ màu đỏ bạn thay đổi tùy ý

 

[lulyen]

Vậy thì code này chắc bạn biết dùng:

Function GetData(ByVal FileName As String, ByVal SheetName As String, ByVal RangeAddress As String, _
            ByVal HasTitle As Boolean, ByVal UseTitle As Boolean)
            
  Dim rsCon As Object, rsData As Object, cat As Object, tbl As Object
  Dim tmpArr, Arr()
  Dim szConnect As String, szSQL As String, tmp As String
  Dim lCount As Long, lR As Long, lC As Long, lVer As Long
  lVer = Val(Application.Version)
  Set rsCon = CreateObject("ADODB.Connection")
  Set rsData = CreateObject("ADODB.Recordset")
  Set cat = CreateObject("ADOX.Catalog")
  
[COLOR=#800000]  If lVer < 12 Then
    szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & FileName & ";" & _
                "Extended Properties=""Excel 8.0;HDR=" & IIf(HasTitle, "Yes", "No") & """;"
  Else
    szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FileName & ";" & _
                "Extended Properties=""Excel 12.0;HDR=" & IIf(HasTitle, "Yes", "No") & """;"
  End If[/COLOR]
  If SheetName = "" Then
    Dim Dbs  As Object, db As Object
   [COLOR=#800000] Set Dbs = CreateObject("DAO.DBEngine." & IIf(lVer < 12, "36", "120"))
    Set db = Dbs.OpenDatabase(FileName, False, False, "Excel 8.0;")
    tmp = db.TableDefs(0).Name
    tmp = Replace(tmp, " ", "?")
    tmp = Replace(tmp, "'", " ")
    tmp = WorksheetFunction.Trim(tmp)
    tmp = Replace(tmp, " ", "'")
    tmp = Replace(tmp, "?", " ")
    SheetName = tmp[/COLOR]
    db.Close
    Set Dbs = Nothing: Set db = Nothing
  End If
  If Right(SheetName, 1) <> "$" Then SheetName = SheetName & "$"
  rsCon.Open szConnect
  cat.ActiveConnection = rsCon
  
  szSQL = "SELECT * FROM [" & SheetName & RangeAddress & "];"
  rsData.Open szSQL, rsCon, 0, 1, 1
  tmpArr = rsData.GetRows
  ReDim Arr(UBound(tmpArr, 2) - UseTitle, UBound(tmpArr, 1) + 1)
  If UseTitle Then
    For lC = LBound(tmpArr, 1) To UBound(tmpArr, 1)
      Arr(0, lC) = rsData.Fields(lC).Name
    Next
  End If
  For lR = LBound(tmpArr, 2) To UBound(tmpArr, 2)
    For lC = LBound(tmpArr, 1) To UBound(tmpArr, 1)
      Arr(lR - UseTitle, lC) = tmpArr(lC, lR)
    Next
  Next
  rsData.Close: Set rsData = Nothing
  rsCon.Close: Set rsCon = Nothing
 [COLOR=#800000] GetData = Arr[/COLOR]
End Function

Áp dụng:

Sub Main()
  Dim Arr
  [COLOR=#b22222]Arr = GetData(ThisWorkbook.Path & "\TTK.XLS", "TTKH", "A1:I2", True, True)
  Range("A1:I2").Value = Arr[/COLOR]
End Sub

Chổ màu đỏ bạn thay đổi tùy ý

Bác ndu có thể giải thích thêm cho em đoạn Code của thầy với ạ, đặc biệt là những chỗ mầu đỏ, em xem mãi mà vẫn không phát hiện ra cách nhặt File nguồn (File có tên TTKH.xls hoặc có thể đặt dưới tên bất kỳ) và thay thế vào Sheet TTCHUNG của File đích (TTCHUNG). Cảm ơn bác nhiều: một thành viên ăn ngủ cùng GPE.

 

[ndu96081631]

Bác ndu có thể giải thích thêm cho em đoạn Code của thầy với ạ, đặc biệt là những chỗ mầu đỏ, em xem mãi mà vẫn không phát hiện ra cách nhặt File nguồn (File có tên TTKH.xls hoặc có thể đặt dưới tên bất kỳ) và thay thế vào Sheet TTCHUNG của File đích (TTCHUNG). Cảm ơn bác nhiều: một thành viên ăn ngủ cùng GPE.

Code ứng dụng ADO, muốn hiểu thì cứ vào topic này nhé:
http://www.giaiphapexcel.com/forum/showthread.php?75143-Bài-tập-về-ADO-căn-bản
Mà dù không hiểu cũng đâu có sao (giống như ta chẳng cần hiểu VLOOKUP nó viết gì)... Chỉ cần biết áp dụng là được
Phần áp dụng tại Sub Main ---> Cứ truyền đủ đối số vào là nó chạy thôi