xuanhoa7604
Thành viên hoạt động
- Tham gia
- 9/6/08
- Bài viết
- 169
- Được thích
- 82
- Nghề nghiệp
- Giáo viên
Bác nào biết cách lấy tên các sheet của một file excel (bằng VBA) mà không cần mở file đó không xin chỉ giáo? Xin cảm ơn trước!
Bạn nghiên cứu code này xem:Bác nào biết cách lấy tên các sheet của một file excel (bằng VBA) mà không cần mở file đó không xin chỉ giáo? Xin cảm ơn trước!
Function GetSheetsNames(WBName As String) As Collection
'Vao menu Tools\References va check cac muc:
'-Microsoft ActiveX Data Object X.X Library
'-Microsoft ADO Ext. X.X for DLL and Security
Dim objConn As ADODB.Connection, objCat As ADOX.Catalog, Col As New Collection, tbl As ADOX.Table
Dim sConnString As String, sSheet As String
sConnString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & WBName & ";" & "Extended Properties=Excel 8.0;"
Set objConn = New ADODB.Connection
objConn.Open sConnString
Set objCat = New ADOX.Catalog
Set objCat.ActiveConnection = objConn
For Each tbl In objCat.Tables
sSheet = tbl.Name
sSheet = Application.Substitute(sSheet, "'", "")
sSheet = Left(sSheet, InStr(1, sSheet, "$", 1) - 1)
On Error Resume Next
Col.Add sSheet, sSheet
On Error GoTo 0
Next tbl
Set GetSheetsNames = Col
objConn.Close
Set objCat = Nothing
Set objConn = Nothing
End Function
Sub Test()
Dim Col As Collection, Book As String, i As Long
Book = "D:\Excel\Book1.xls"
Set Col = GetSheetsNames(Book)
For i = 1 To Col.Count
MsgBox Col(i)
Next i
End Sub
File rất hoành tráng, tuy nhiên code dài quá ---> Nếu có thời gian rảnh rỗi bạn hãy làm cho nó gọn lại chút nhéThêm cho bạn 1 cách lấy tên sheet cho tất cả các file có trong folder bằng listbox
Bạn xem file nhé
Thân
Dùng phương pháp mở file rồi lấy tên sheet đúng là khá gọn, tuy nhiên nếu lấy tên sheet của chính file hiện hành thì phải.. coi chừng (báo lổi) ---> Khi đó phải chỉnh lại code cho hợp lý (đại khái nếu chọn vào tên file hiện hành thì không mở file và vòng lập duyệt trực tiếp vào các sheet của file)Thực ra nói không mở file nhưng ta vẫn mở file mà không biết (mở kiểu ẩn), khi đó thủ tục gọn nhẹ hơn nhiều.
Private Sub cmdSelDir_Click()
Dim i As Long, MyDir As String
On Error Resume Next
lstWB.Clear
With Application.FileDialog(4)
.AllowMultiSelect = False: .Show:
MyDir = .SelectedItems(1)
txtUserDir = MyDir
With Application.FileSearch
.LookIn = MyDir: .Filename = "*.xls"
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
lstWB.AddItem Replace(.FoundFiles(i), MyDir & "\", "")
Next
End If
End With
End With
End Sub
Private Sub lstWB_Click()
Dim i As Long
Application.ScreenUpdating = False
lstWS.Clear
For i = 1 To GetSheetsNames(lstWB.Value).Count
lstWS.AddItem GetSheetsNames(lstWB.Value)(i)
Next
Application.ScreenUpdating = True
End Sub
Bác nào biết cách lấy tên các sheet của một file excel (bằng VBA) mà không cần mở file đó không xin chỉ giáo? Xin cảm ơn trước!
Sub LayTenSh()
Dim a As String, Ten As String
Dim Wb As Workbook
Dim Ws As Worksheet
a = "D:\TongHop\GPE.xls"
Set Wb = GetObject(a)
For Each Ws In Wb.Sheets
MsgBox "Ten Sheet la " & Ws.Name, , "Thong Bao"
Next
End Sub
AnhPhuong xem lại nha... Code này tuy có gọn thật, nhưng vẫn còn rất nhiều nhược điểm cần giải quyết:Đây là code lấy tên Sheet của một file Excel không mở. Bạn chép code sau vào module của một file Excel rồi chạy nó. Lưu ý trước khi chạy, bạn cần đổi lại tên File cần lấy Sheet name cho phù hợp, tránh xảy ra lỗi
Thân
PHP:Sub LayTenSh() Dim a As String, Ten As String Dim Wb As Workbook Dim Ws As Worksheet a = "D:\TongHop\GPE.xls" Set Wb = GetObject(a) For Each Ws In Wb.Sheets MsgBox "Ten Sheet la " & Ws.Name, , "Thong Bao" Next End Sub
For Each tbl In objCat.Tables
sSheet = tbl.Name
.......
Next tbl
For Each tbl In objCat.Tables
If Right(tbl.Name, 1) = "$" Or Right(tbl.Name, 2) = "$'" Then
sSheet = Replace(Replace(tbl.Name, "$", ""), "'", "")
End If
Col.Add sSheet, sSheet
Next tbl
Function GetSheetsNames(WBName As String)
Dim Temp As String
...................
'Đoạn này giữ nguyên code cũ
...................
For Each tbl In objCat.Tables
If Right(tbl.Name, 1) = "$" Or Right(tbl.Name, 2) = "$'" Then
Temp = Temp & Chr(10) & Replace(Replace(tbl.Name, "$", ""), "'", "")
End If
Next tbl
GetSheetsNames = Split(Mid(Temp, 2, Len(Temp)), Chr(10))
objConn.Close
End Function
Private Sub lstWB_Click()
lstWS.List() = GetSheetsNames(lstWB.Value)
End Sub
For Each tbl In objCat.Tables
If InStr(tbl.Name, "$") = 0 Then
Temp = Temp & Chr(10) & tbl.Name 'Replace(Replace(tbl.Name, "$", ""), "'", "")
End If
Next tbl
Private Sub cmdSelDir_Click()
On Error GoTo Thoat
lstWB.Clear
With Application.FileDialog(4)
.AllowMultiSelect = False: .Show
txtUserDir = .SelectedItems(1)
End With
Thoat:
End Sub
Private Sub txtUserDir_Change()
Dim Temp As String, fN
On Error Resume Next
With CreateObject("Scripting.FileSystemObject")
For Each fN In .GetFolder(txtUserDir).Files
If InStr(Right(fN.Name, 5), ".xls") Then
Temp = Temp & Chr(10) & fN.Name
End If
Next
End With
lstWB.List() = Split(Mid(Temp, 2, Len(Temp)), Chr(10))
End Sub
Private Sub lstWB_Click()
Dim objConn As ADODB.Connection, objCat As ADOX.Catalog, tbl As ADOX.Table, Temp As String
On Error Resume Next
lstWS.Clear
Set objConn = New ADODB.Connection
objConn.Open "Provider=MSDASQL.1;Data Source=Excel Files; Initial Catalog=" & txtUserDir & "\" & lstWB
Set objCat = New ADOX.Catalog
Set objCat.ActiveConnection = objConn
For Each tbl In objCat.Tables
If Right(tbl.Name, 1) = "$" Or Right(tbl.Name, 2) = "$'" Then
Temp = Temp & Chr(10) & Replace(Replace(tbl.Name, "$", ""), "'", "")
End If
Next tbl
lstWS.List() = Split(Mid(Temp, 2, Len(Temp)), Chr(10))
objConn.Close
End Sub
Cách Import data từ 1 Workbook đang đóng đã từng nói nhiều rồi.. Theo em, anh nên dùng ADO (vì những ưu điểm vượt trội của nó)Cảm ơn anhtuan1066! Mình đã test và thấy bài này rất hay. Cho mình hỏi thêm từ sub này có thể phát triển thêm để khi ta Clich vào tên Sheet thì Sheet đó được Copy vào sheet hiện hành được không ? hiện tại trên GPE đã có sub lấy sheet (dùng cách mở File copy sheet xong đóng lại) chạy tương đối tốt nhưng có hạn chế là chỉ chọn được 1 file và đối với File dung lượng lớn, nhiều sheet thì chạy hơi chậm.
Hôm nay em dự định viết bài hỏi về vấn đề này, nhưng anh TrungChinh đã hỏi trước, em nghĩ dùng công cụ này phát triển ra thêm 1 listbox nữa để chọn tên sheet cần tổng hợp vào file trên nhiều file. Ý này rất hay.Cách Import data từ 1 Workbook đang đóng đã từng nói nhiều rồi.. Theo em, anh nên dùng ADO (vì những ưu điểm vượt trội của nó)
Anh có thể tham khảo tại đây:
http://www.erlandsendata.no/english/index.php?d=envbadacimportwbado
Việc còn lại của anh là: Copy code, sửa lại đường dẩn đến file và chạy thử
AnhPhuong xem lại nha... Code này tuy có gọn thật, nhưng vẫn còn rất nhiều nhược điểm cần giải quyết:
- Mổi lân ta lấy sheet name là 1 file được mở lên nhưng không được đóng lại ---> Có thể bấm Alt + F11 để kiểm tra, sẽ thấy tên file mở lần trước vẫn tồn tại
- Nếu ta thêm đoạn Wb.Close vào để đóng file thì lại thêm 1 chuyện rắc rối: Khi lấy tên sheet trên file hiện hành xong, nó tự đóng chính nó luôn
- Với Function dùng ADO thì lại hoàn toàn không có các hiện tượng trên
Vậy theo AnhPhuong ta giải quyết chuyện này thế nào đây?
Sub LayTenSh()
With Application
.ScreenUpdating=False
.DisplayAlerts = False
End With
On Error Resume Next
Dim a As String, Ten As String
Dim Wb As Workbook
Dim Ws As Worksheet
a = "D:\TongHop\GPE.xls"
Ten = TimFile(a)
Set Wb = GetObject(a)
For Each Ws In Wb.Sheets
MsgBox "Ten Sheet la " & Ws.Name, , "Thong Bao"
Next
Windows(Ten).Close False
With Application
.ScreenUpdating=True
.DisplayAlerts = True
End With
End Sub
Cũng không được đâu! Nói chung là cách này có rất nhiều nhược điểm:Xin lỗi ndu96081631 và các bạn vì thời gian qua quá bận nên không thường xuyên lên mạng được vì thế hôm nay trả lời hơi trễ, mong các bạn thông cảm. Về vấn đề này, anhphuong xin được phép trả lời như sau :
1/ Thêm một hàm TimFile(Duongdan As String) để tìm ra tên một file từ đường dẫn cho trước. Hàm này tương tự như hàm tách tên để lấy tên ra từ Họ Tên cho trước
2/ Không thể dùng Wb.Close được vì nó đóng chính file đang chạy code.
Và dưới đây là code chạy :
Thân mếnPHP:Sub LayTenSh() With Application .ScreenUpdating=False .DisplayAlerts = False End With On Error Resume Next Dim a As String, Ten As String Dim Wb As Workbook Dim Ws As Worksheet a = "D:\TongHop\GPE.xls" Ten = TimFile(a) Set Wb = GetObject(a) For Each Ws In Wb.Sheets MsgBox "Ten Sheet la " & Ws.Name, , "Thong Bao" Next Windows(Ten).Close False With Application .ScreenUpdating=True .DisplayAlerts = True End With End Sub
Cách Import data từ 1 Workbook đang đóng đã từng nói nhiều rồi.. Theo em, anh nên dùng ADO (vì những ưu điểm vượt trội của nó)
Anh có thể tham khảo tại đây:
http://www.erlandsendata.no/english/index.php?d=envbadacimportwbado
Việc còn lại của anh là: Copy code, sửa lại đường dẩn đến file và chạy thử
Quả đúng là code ấy có vấn đề với Font tiếng ViệtRRRRR... đã nhiều lần theo link của Ndu nhưng không làm được vì mù tiếng anh nên chẳng biết Copy đoạn nào (chỉ mở ra xem rồi đậy lại chẳng làm được gì) hôm nay điên tiết copy tất cả bài dán vào module thấy chữ nào lỗi thì xoá rồi sửa lại đường dẩn và chạy thử thì lấy được dữ liệu nhưng chẳng biết có xoá nhầm đoạn nào không mà chẳng thấy MsgBox nào hiện ra và bị lỗi Font mặc dù Sheet nguồn và Sheet đích đều dùng Unicode...hết võ. Bạn nào biết sửa code này (trong link) giúp mình với. Xin cảm ơn !
Cũng không được đâu! Nói chung là cách này có rất nhiều nhược điểm:
- AnhPhuong làm sao GetSheetName cho chính file hiện hành?
- Có thể GetSheetName cho 1 file đang bị lổi code không? (tức code bị lổi ngay khi open)
và còn rất nhiều trường hợp khác mà ta không thể dùng cách này được
Tóm lại: Open file là BẤT KHẢ THI
Sub LayTenSh()
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
On Error Resume Next
Dim Ten As String
Dim Ex As Excel.Application
Dim Wb As Excel.Workbook
Dim Ws As Excel.Worksheet
Ten = "E:\TongHop\GPE.xls"
Set Ex = New Excel.Application
Set Wb = Ex.Workbooks.Open(Ten)
For Each Ws In Wb.Sheets
MsgBox "Ten Sheet la " & Ws.Name, , "Thong Bao"
Next
Ex.Application.DisplayAlerts = False
Wb.Close: Set Wb = Nothing: Set Ex = Nothing
Ex.Application.DisplayAlerts = True
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
Có lẻ bác chưa hiểu ý emLâu lắm rồi mới quay lại GPE và gặp lại bài này. Xin chia sẻ một đoạn code sau, mọi người cùng tham khảo
Các bác xem và cho ý kiến nhéPHP:Sub LayTenSh() With Application .ScreenUpdating = False .DisplayAlerts = False End With On Error Resume Next Dim Ten As String Dim Ex As Excel.Application Dim Wb As Excel.Workbook Dim Ws As Excel.Worksheet Ten = "E:\TongHop\GPE.xls" Set Ex = New Excel.Application Set Wb = Ex.Workbooks.Open(Ten) For Each Ws In Wb.Sheets MsgBox "Ten Sheet la " & Ws.Name, , "Thong Bao" Next Ex.Application.DisplayAlerts = False Wb.Close: Set Wb = Nothing: Set Ex = Nothing Ex.Application.DisplayAlerts = True With Application .ScreenUpdating = True .DisplayAlerts = True End With End Sub
Thân