Việc tách 2 tập tin dữ liệu và chương trình riêng giúp cho việc quản lý, sử dụng thuận tiện hơn.yeudoi đã viết:
Tôi thường sử dụng sheet để nhập dữ liệu. Khi chạy file chính (gọi là chương trình) sẽ mở file .xls chứa dữ liệu chuyển vào sheet nhập, sau khi sửa/nhập xong thì lại mở file dữ liệu để cập nhật lại số liệu. File dữ liệu là .xls nhưng đặt lại .xyz đều được.yeudoi đã viết:
Nếu dùng ADO thì gồm có 2 file (1 file Access + 1 file Excel) File Excel muốn mấy Sheet cũng được anh à.yeudoi đã viết:
Option Explicit
'Look in the Examples module how you can call this macro
[B]Public Sub GetDataFromAccess[/B](MyDatabaseFilePathAndName As String, MyTable As String, _
MyTableField1 As String, S1 As String, MyFieldValue1 As String, _
MyTableField2 As String, S2 As String, MyFieldValue2 As String, _
MyTableField3 As String, S3 As String, MyFieldValue3 As String, _
MyTableField4 As String, S4 As String, MyFieldValue4 As String, _
MyTableField5 As String, S5 As String, MyFieldValue5 As String, _
MyTableField6 As String, S6 As String, MyFieldValue6 As String, _
MyTableField7 As String, S7 As String, MyFieldValue7 As String, _
DestSheetRange As Range, WhichFields As String, _
FieldNames As Boolean, ClearRange As Boolean)
Dim MyConnection As String
Dim MySQL As String
Dim MyDatabase As Object
Dim col As Integer
Dim I As Integer
Dim str1 As Variant
Dim str2 As Variant
Dim str3 As Variant
'Select the DestSheetRange where you paste the records
Application.GoTo DestSheetRange
'If ClearRange = True it clear all cells on that sheet first
If ClearRange Then Range(DestSheetRange.Address, "IV" & Rows.Count).ClearContents
'Create connection string
MyConnection = "Provider=Microsoft.Jet.OLEDB.4.0;"
MyConnection = MyConnection & "Data Source=" & MyDatabaseFilePathAndName & ";"
' Create MySQL string
str1 = Array(MyTableField1, MyTableField2, MyTableField3, MyTableField4, MyTableField5, MyTableField6, MyTableField7)
str2 = Array(S1, S2, S3, S4, S5, S6, S7)
str3 = Array(MyFieldValue1, MyFieldValue2, MyFieldValue3, MyFieldValue4, MyFieldValue5, MyFieldValue6, MyFieldValue7)
MySQL = ""
For I = LBound(str1) To UBound(str1)
If str3(I) <> "" Then
If MySQL = "" Then
If I <= 2 Then
MySQL = "SELECT " & WhichFields & " FROM " & MyTable & " WHERE [" _
& str1(I) & "] " & str2(I) & " '" & str3(I) & "'"
ElseIf I = 3 Or I = 4 Then
MySQL = "SELECT " & WhichFields & " FROM " & MyTable & " WHERE [" _
& str1(I) & "] " & str2(I) & " " & str3(I)
ElseIf I = 5 Or I = 6 Then
MySQL = "SELECT " & WhichFields & " FROM " & MyTable & " WHERE [" _
& str1(I) & "] " & str2(I) & " #" & str3(I) & "#"
End If
Else
If I <= 2 Then
MySQL = MySQL & " and [" & str1(I) & "] " & str2(I) & " '" & str3(I) & "'"
ElseIf I = 3 Or I = 4 Then
MySQL = MySQL & " and [" & str1(I) & "] " & str2(I) & " " & str3(I)
ElseIf I = 5 Or I = 6 Then
MySQL = MySQL & " and [" & str1(I) & "] " & str2(I) & " #" & str3(I) & "#"
End If
End If
End If
Next I
'If MySQL is empty copy all records
If MySQL = "" Then MySQL = "SELECT " & WhichFields & " FROM " & MyTable & ";"
' Open the database and copy the data
On Error GoTo SomethingWrong
Set MyDatabase = CreateObject("adodb.recordset")
MyDatabase.Open MySQL, MyConnection, 0, 1, 1
' Check to make sure we received data and copy the data
If Not MyDatabase.EOF Then
'If FieldNames = True copy the field names and records
'If = False copy only records
If FieldNames Then
For col = 0 To MyDatabase.Fields.Count - 1
DestSheetRange.Offset(0, col).Value = MyDatabase.Fields(col).Name
Next
DestSheetRange.Offset(1, 0).CopyFromRecordset MyDatabase
Else
DestSheetRange.CopyFromRecordset MyDatabase
End If
Else
MsgBox "No records returned from : " & MyDatabaseFilePathAndName, vbCritical
End If
MyDatabase.Close
Set MyDatabase = Nothing
Exit Sub
SomethingWrong:
On Error GoTo 0
Set MyDatabase = Nothing
MsgBox "Error copying data", vbCritical, "Test Access data to Excel"
End SubOption Explicit
'This are the field names from the Order table in the OrderDatabase.mdb database.
'OrderNumber
'OrderDate
'RequiredDate
'ShippedDate
'Freight
'ShipVia
'ShipCountry
'ShipName
'ShipAddress
'ShipCity
'ShipRegion
'ShipPostalCode
'NOTE :
'First line: Path/name of the Access file, Table name
'Second-Eighth line: You can fill in seven criteria,
'and if you not fill in any criteria it return all records
'
'The first three criteria are only for Text fields
'The fourth and fifth are for numbers fields
'The sixth and seventh are for date fields
'
'Line nine: Destination sheet/range
'Line ten: Which field names (* = all), Copy field names, clear all cells on Destination sheet first
'Instead of enter field values in the code you can also use a cell value
' "ShipVia", "=", Sheets("Sheet1").Range("A2").Value
'Note: look at the other example workbook where you save your different criteria (very easy)
'You can use Data>Validation cells in that workbook
Sub Test1()
'This example retrieves the data for the records in which ShipCountry = Germany
GetDataFromAccess ThisWorkbook.Path & "/OrderDatabase.mdb", "Orders", _
"ShipCountry", "=", "Germany", _
"", "=", "", _
"", "=", "", _
"", ">", "", _
"", "<", "", _
"", ">=", "", _
"", "<=", "", _
Sheets("test").Range("A8"), _
"*", True, True
End Sub
Sub Test2()
'This example retrieves also the data for the records in which ShipCountry = Germany
'It only retrieves this four fields: OrderNumber, ShipName, ShipAddress, ShipPostalCode
'I changed the "*" for WhichFields in the code to the names of the fields
GetDataFromAccess ThisWorkbook.Path & "/OrderDatabase.mdb", "Orders", _
"ShipCountry", "=", "Germany", _
"", "=", "", _
"", "=", "", _
"", ">", "", _
"", "<", "", _
"", ">=", "", _
"", "<=", "", _
Sheets("test").Range("A8"), _
"OrderNumber, ShipName, ShipAddress, ShipPostalCode", True, True
End Sub
Sub Test3()
'This example retrieves the data for the records in which
'ShipCountry = Germany and ShipVia = Speedy Express
GetDataFromAccess ThisWorkbook.Path & "/OrderDatabase.mdb", "Orders", _
"ShipCountry", "=", "Germany", _
"ShipVia", "=", "Speedy Express", _
"", "=", "", _
"", ">", "", _
"", "<", "", _
"", ">=", "", _
"", "<=", "", _
Sheets("test").Range("A8"), _
"*", True, True
End Sub
Sub Test4()
'This example retrieves the data for the records in which
'ShipCountry = Germany and ShipVia = Speedy Express
'and Freight = between 100 and 300
GetDataFromAccess ThisWorkbook.Path & "/OrderDatabase.mdb", "Orders", _
"ShipCountry", "=", "Germany", _
"ShipVia", "=", "Speedy Express", _
"", "=", "", _
"Freight", ">", "100", _
"Freight", "<", "300", _
"", ">=", "", _
"", "<=", "", _
Sheets("test").Range("A8"), _
"*", True, True
End Sub
Sub Test5()
'This example retrieves the data for the records in which
'ShipCountry = Germany and ShipVia = Speedy Express
'and ShippedDate = between 1/1/1998 and 3/1/1998
GetDataFromAccess ThisWorkbook.Path & "/OrderDatabase.mdb", "Orders", _
"ShipCountry", "=", "Germany", _
"ShipVia", "=", "Speedy Express", _
"", "=", "", _
"", ">", "", _
"", "<", "", _
"ShippedDate", ">=", "1/1/1998", _
"ShippedDate", "<=", "3/1/1998", _
Sheets("test").Range("A8"), _
"*", True, True
End Sub
Sub Test6()
'This example retrieves all records
GetDataFromAccess ThisWorkbook.Path & "/OrderDatabase.mdb", "Orders", _
"", "=", "", _
"", "=", "", _
"", "=", "", _
"", ">", "", _
"", "<", "", _
"", ">=", "", _
"", "<=", "", _
Sheets("test").Range("A8"), _
"*", True, True
End Sub
ok,Thien đã viết:
:\PTC_DataNotChangebyYear\VBACode_Only\CopyAllCase_IniFile.xlsOption Explicit
Dim destWB As Workbook, sourceWB As Workbook
'Dim destWk As Worksheet, sourceWk As Worksheet
Dim sourceRange As Range, destrange As Range
Dim intRow As Integer
Dim smallrng As Range, DongFlag As String
Dim StrsourceWB As String, StrdestWB As String
Sub copy_to_another_workbook() ' Area to Range lien tuc, chep tung cai, bang resize
Dim SWbName As String
SWbName = "HDGTGTToData_IniFile.xls"
DongFlag = "A21"
Dim WbIniFile As Workbook
Application.ScreenUpdating = False
MsgBox "THAY doi o bien DongFlag khi chay so hoa don moi, kiem tra khi on dinh roi se dua vao vong lap"
'Lay ten source va destination,sau do dong lai
If bIsBookOpen(SWbName) Then
Set WbIniFile = Workbooks(SWbName)
Else
Set WbIniFile = Workbooks.Open(ThisWorkbook.Path & "\" & SWbName)
End If
With WbIniFile.Worksheets("Sheet1")
intRow = .Range(DongFlag).Row
If bIsBookOpen(.Cells(intRow, 2)) Then
StrsourceWB = .Cells(intRow, 2)
Set sourceWB = Workbooks(StrsourceWB) '
Else
Set sourceWB = Workbooks.Open(Left(ThisWorkbook.Path, 3) & "PTC" & "\" & .Cells(intRow, 6) & "\" & .Cells(intRow, 2))
'Set sourceWk = Workbooks(.Cells(intRow, 2)).Worksheets(.Cells(intRow, 3)) khg the dung wk duoc, tot nhat cu theo cai co san da
End If
If bIsBookOpen(.Cells(5, 7)) Then
StrdestWB = .Cells(5, 7)
Set destWB = Workbooks(StrdestWB)
Else
Set destWB = Workbooks.Open(Left(ThisWorkbook.Path, 3) & "PTC" & "\" & .Cells(5, 11) & "\" & .Cells(5, 7))
End If
End With
WbIniFile.Close True
Set WbIniFile = Nothing
' Chep sang tabe1 cua data
'Windows("2007HDGTGT_Data.xls").Activate
Dim LastPlc As Integer, i As Integer
i = 1
With destWB 'dung with qua hay va thuan tien,nhung hay bat dau bang Activate de code chay on ding da
LastPlc = Application.CountA(.Worksheets("Data").Range("a:a")) + 1 'Find last cell/row plus one
End With
For Each smallrng In sourceWB.Worksheets("Sheet1").Range("e2,e3,i4,i12,i15").Areas
Set destrange = Worksheets("Data").Cells(LastPlc, i)
destrange.Value = smallrng.Value
i = i + 1
Next smallrng
'' Chep sang tabe2 cua data
Dim SoDong As Integer, LastPlc2 As Integer
Dim DataCount As Range
Set DataCount = Worksheets("Data").Range("g:g")
LastPlc2 = Application.CountA(DataCount) + 1 'kieu nay hay hon xlDown phai co min 2 cell, nhung phai chon duoc vung dem co dinh
'sourceWB.Worksheets("Sheet1").Activate
'Mot cai do cua xlDown la vung data phai co it nhat 2 Cells thi moi dung, do do doi a19->17, nen doc them NotEmpty cho nay
With sourceWB.Worksheets("Sheet1")
SoDong = Application.WorksheetFunction.CountA(.Range("A17:A" & .Range("a18").End(xlDown).Row)) - 2
End With
'destWB.Worksheets("Data").Activate
i = 0
With Worksheets("Data")
For i = 0 To SoDong - 1
'Dim i2 As Integer
'i2 = 7
'For Each smallrng In sourceWB.Worksheets("Sheet1").Range("e3")
'.Cells(LastPlc2, i2) = smallrng
' i2 = i2 + 1
.Cells(LastPlc2, 7) = sourceWB.Worksheets("Sheet1").Range("e3")
.Cells(LastPlc2, 8) = sourceWB.Worksheets("Sheet1").Range("a19").Offset(i, 0)
.Cells(LastPlc2, 9) = sourceWB.Worksheets("Sheet1").Range("b19").Offset(i, 0)
.Cells(LastPlc2, 9).WrapText = False
.Cells(LastPlc2, 10) = sourceWB.Worksheets("Sheet1").Range("c19").Offset(i, 0)
.Cells(LastPlc2, 11) = sourceWB.Worksheets("Sheet1").Range("d19").Offset(i, 0)
.Cells(LastPlc2, 12) = sourceWB.Worksheets("Sheet1").Range("e19").Offset(i, 0)
' Next smallrng
LastPlc2 = Application.CountA(DataCount) + 1
Next
End With
sourceWB.Close True
'destWB.Close True
Set sourceWB = Nothing
'Set destWB = Nothing
'CloseMe
End Sub
Sub thongbao()
MsgBox "Da default o rANGE a4, A3 la dong mau,HAY close file nay va mo file ini, copy du lieu muon lam viec len A3"
End Sub
Sub CloseMe()
ThisWorkbook.Close True
End Sub
Sao tôi tìm hoài cũng ko thấy có gì hay trong này nhỉ? Ko có code, ko có công thức... Toàn chử và số.. nhìn chẳng hiểu gì cả... Thầy Phước có thể bật mí cái hay của nó là gì dc ko?
