Giúp lệnh lấy dữ liệu từ nhiều tệp bị đặt Protect Workbook vào một tệp

Liên hệ QC

titanic20072007

Thành viên thường trực
Tham gia
10/7/07
Bài viết
213
Được thích
8
Nghề nghiệp
Giáo viên
Chào các bạn. Mình có đoạn code lấy DL từ nhiều tệp có cùng cấu trúc vào một sheet chạy ổn rồi nhưng nếu các tệp kia bị đặt Protect Workbook thì không lấy được DL. Nhờ các bạn chỉ giúp cách giải quyết. Cảm ơn nhiều.
....
vFile = Application.GetOpenFilename("Excel File, *.xls; *.xlsx; *.xlsm", , , , True)
Tensheet = ActiveSheet.CodeName
VungDL = "Khoi 9": RangeAddress = "B6:H341"
Range("B8:AC8071").ClearContents
Range("AE8:AE8071").ClearContents
If TypeName(vFile) = "Variant()" Then
SheetName = VungDL
For Each FileItem In vFile
FileName = CStr(FileItem)
If UCase(FileName) <> UCase(ThisWorkbook.FullName) Then
aRes = GetData(FileName, SheetName, RangeAddress, False, False)
If IsArray(aRes) Then
Set Target = Range("B60000").End(xlUp).Offset(1)
Target.Resize(UBound(aRes, 1) + 1, UBound(aRes, 2)).Value = aRes
End If
End If
Next
End If
 
Lần chỉnh sửa cuối:
Có cho thấy mặt mũi cái hàm GetData ra sao đâu mà hỏi.
 
Upvote 0
Có cho thấy mặt mũi cái hàm GetData ra sao đâu mà hỏi.
Đây các bạn xem giúp.
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
 
Lần chỉnh sửa cuối:
Upvote 0
Không tiện cũng phải tiện, bạn nhớ phải có khóa họ gửi cho
Hoặc thủ công, hoặc code thì cũng phải biết password để mở
Giả sử là biết pass của workbook đi thì minh thử unprotect rồi vẫn không được.
Bài đã được tự động gộp:

Giả sử là biết pass của workbook đi thì minh thử unprotect rồi vẫn không được. Chính xác là không unprotect được.
 
Upvote 0
Khi protect có nghĩa là mã hoá workbook. ADO không đọc được workbook đã mã hoá.
Cách đi vòng qua là dùng lệnh GetObject để mở workbook. Khi đã mở thì có một phiên bản đã giải mã trong bộ nhớ. Và ADO có thể đọc phiên bản này.
 
Upvote 0
Web KT
Back
Top Bottom