Xin chào các a/c GPE
Mình có nhiều flie, mỗi file có nhiều sheet, tên sheet cũng là tên mã hàng,
mình muốn lấy tên các sheet đó bỏ vào 1 file"thongke.mahang"
khi chạy code thì các file đó vẫn đóng, chỉ có file "thongke.mahang" là mở. sau khi chạy xong mình sẽ biết được có tất cả bao nhiệu mã hàng
Lỡ phóng lao rồi ráng đeo theo anh NDU bài này
Code này hình như xử được tiếng Việt đây.
PHP:
Sub GetSheetNames()
Dim Con As Object, Cat As Object, Fso As Object, ObjFile
Dim Tbl As Object, Res(1 To 10000, 1 To 1), k As Long
Set Con = CreateObject("ADODB.Connection")
Set Cat = CreateObject("ADOX.Catalog")
Set Tbl = CreateObject("ADOX.Table")
Set Fso = CreateObject("Scripting.FileSystemObject")
With Fso.GetFolder(ThisWorkbook.Path)
For Each ObjFile In .Files
If Not UCase(ObjFile.Name) Like "~*.XLS*" Then
If ObjFile <> ThisWorkbook.FullName Then
Con.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"extended properties=excel 8.0;data source=" & ObjFile
Cat.ActiveConnection = Con
For Each Tbl In Cat.Tables
k = k + 1
Res(k, 1) = Replace(Replace(Tbl.Name, "$", ""), "'", "")
Next
Con.Close
End If
End If
Next
End With
Sheets("MAHANG").[A2].Resize(k) = Res
End Sub
Chính thống như anh NDU thì khó chứ theo kiểu Thiếu Lâm như mình thì cũng không ngại lắm.
PHP:
Sub GetSheetNames2()
Dim Con As Object, Cat As Object, Fso As Object, ObjFile
Dim Tbl As Object, Res(1 To 10000, 1 To 1), k As Long
Set Con = CreateObject("ADODB.Connection")
Set Cat = CreateObject("ADOX.Catalog")
Set Tbl = CreateObject("ADOX.Table")
Set Fso = CreateObject("Scripting.FileSystemObject")
With Fso.GetFolder(ThisWorkbook.Path)
For Each ObjFile In .Files
If Not UCase(ObjFile.Name) Like "~*.XLS*" Then
If ObjFile <> ThisWorkbook.FullName Then
Con.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"extended properties=excel 8.0;data source=" & ObjFile
Cat.ActiveConnection = Con
For Each Tbl In Cat.Tables
k = k + 1
Res(k, 1) = Replace(Replace(Tbl.Name, "$", ""), "''", "$")
Res(k, 1) = Replace(Replace(Res(k, 1), "'", ""), "$", "'")
Next
Con.Close
End If
End If
Next
End With
Sheets("MAHANG").[A2].Resize(k) = Res
End Sub
Chính thống như anh NDU thì khó chứ theo kiểu Thiếu Lâm như mình thì cũng không ngại lắm.
PHP:
Sub GetSheetNames2()
Dim Con As Object, Cat As Object, Fso As Object, ObjFile
Dim Tbl As Object, Res(1 To 10000, 1 To 1), k As Long
Set Con = CreateObject("ADODB.Connection")
Set Cat = CreateObject("ADOX.Catalog")
Set Tbl = CreateObject("ADOX.Table")
Set Fso = CreateObject("Scripting.FileSystemObject")
With Fso.GetFolder(ThisWorkbook.Path)
For Each ObjFile In .Files
If Not UCase(ObjFile.Name) Like "~*.XLS*" Then
If ObjFile <> ThisWorkbook.FullName Then
Con.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"extended properties=excel 8.0;data source=" & ObjFile
Cat.ActiveConnection = Con
For Each Tbl In Cat.Tables
k = k + 1
Res(k, 1) = Replace(Replace(Tbl.Name, "$", ""), "''", "$")
Res(k, 1) = Replace(Replace(Res(k, 1), "'", ""), "$", "'")
Next
Con.Close
End If
End If
Next
End With
Sheets("MAHANG").[A2].Resize(k) = Res
End Sub
Vẫn còn nữa chứ chưa xong đâu.
Code của Hải nếu lấy tên sheet nhưng file cần lấy lại có 1 số name nào đó thì kết quả cũng sai luôn (code lấy tên sheet đồng thời lấy luôn name)
Function GetSheets([COLOR=#ff0000]ByVal InThisFile As Boolean[/COLOR], ParamArray ExcelFiles())
Dim Dbs As Object, db As Object
Dim tbItem, aTmp, item, arr(), tmp As String
Dim n As Long, i As Long, lVersn As Long
lVersn = Val(Application.Version)
Set Dbs = CreateObject("DAO.DBEngine." & IIf(lVersn < 12, "36", "120"))
For i = LBound(ExcelFiles) To UBound(ExcelFiles)
aTmp = ExcelFiles(i)
If Not IsArray(aTmp) Then aTmp = Array(aTmp)
For Each item In aTmp
If TypeName(item) = "String" Then
If UCase$(item) Like "*.XLS" Or UCase$(item) Like "*.XLS?" Then
[COLOR=#ff0000]If Not (UCase$(item) Like "*~$*.XLS*") Then[/COLOR]
If (CStr(item) <> ThisWorkbook.FullName) Or InThisFile Then
Set db = Dbs.OpenDatabase(CStr(item), False, False, "Excel 8.0;")
For Each tbItem In db.TableDefs
tmp = tbItem.Name
[COLOR=#ff0000]tmp = Replace(tmp, "''", "'")[/COLOR]
[COLOR=#ff0000]If Right(tmp, 1) = "$" Or Right(tmp, 2) = "$'" Then[/COLOR]
If Right(tmp, 2) = "$'" Then
tmp = Mid(tmp, 2, Len(tmp) - 3)
Else
If Right(tmp, 1) = "$" Then tmp = Left(tmp, Len(tmp) - 1)
End If
n = n + 1
ReDim Preserve arr(1 To n)
arr(n) = tmp
End If
Next
db.Close
End If
End If
End If
End If
Next
Next
If n Then GetSheets = arr
Set Dbs = Nothing
End Function
Mã:
Function FilesFoldersList(ByVal RootFolder As String, ByVal ListType As Boolean, _
ByVal Search As String, ByVal InSub As Boolean)
'ListType = True: Get Files list
'ListType = False: Get Folders list
Dim sComm As String, tmp As String, str As String, tmpFile, arr
On Error Resume Next
If Right(RootFolder, 1) <> "\" Then RootFolder = RootFolder & "\"
str = """" & RootFolder & Search & """"
With CreateObject("Scripting.FileSystemObject")
tmpFile = .GetTempName
'sComm = "DIR " & str & " /ON /B /A" & IIf(ListType, "-", "") & "D-S" & IIf(InSub, "/S", " ") & " >" & tmpFile
sComm = "DIR " & str & " /ON /B /A" & IIf(ListType, "-", "") & "D" & IIf(InSub, "/S", " ") & " >" & tmpFile
CreateObject("Wscript.Shell").Run "cmd /u /c " & sComm, 0, True
With .OpenTextFile(tmpFile, 1, , -2)
tmp = Trim(.ReadAll)
If Right(tmp, 2) = vbCrLf Then tmp = Left(tmp, Len(tmp) - 2)
If Len(tmp) Then
If InSub = False Then tmp = RootFolder & Replace(tmp, vbCrLf, vbCrLf & RootFolder)
FilesFoldersList = Split(tmp, vbCrLf)
End If
.Close
End With
End With
Kill tmpFile
End Function
Mã:
Sub Main()
Dim path As String
Dim aFiles, aRes
Sheet1.Range("A2:A10000").ClearContents
path = ThisWorkbook.path
aFiles = FilesFoldersList(path, True, "*.xls", False)
If IsArray(aFiles) Then
aRes = GetSheets(False, aFiles)
If IsArray(aRes) Then
Sheet1.Range("A2").Resize(UBound(aRes)).Value = WorksheetFunction.Transpose(aRes)
End If
End If
End Sub
Tên file tiếng Việt hoặc tên Sheet tiếng Việt gì cũng chơi tuốt
-----------------
Một vài giải thích:
- Hàm GetSheets cho phép lấy tên sheet với đối số đầu vào ExcelFiles là mảng gồm nhiều file cùng lúc
- Hàm GetSheets có thêm đối số InThisFile với ngụ ý cho phép lấy tên sheet của chính file chứa code hoặc không (trong trường hợp file chứa code nằm cùng thư mục với các file cần lấy)
- Trong trường hợp các bạn mở 1 file Excel lên, Windows sẽ tạo ra 1 file tạm có tên dạng ~$Tên file. Vậy nên ta cần có đoạn code If Not (UCase$(item) Like "*~$*.XLS*") Then để loại bỏ file tạm này (khi bạn lấy tên sheet từ file mà file ấy đang mở)
- Nếu trong tên sheet có ký tự ' (dấu nháy đơn) thì DAO sẽ nhân ký tự này thành 2. Vậy nên ta có đoạn code này tmp = Replace(tmp, "''", "'")
- DAO sẽ xem Name Range cũng là 1 Table và lấy luôn. Điểm phân biệt giữa Sheet và Name Range là tên sheet sẽ kết thúc bằng ký tự $ hoặc $'. Vậy ta cũng có đoạn code này If Right(tmp, 1) = "$" Or Right(tmp, 2) = "$'" Then để chỉ lấy tên sheet chứ không lấy Name
-------------------
Trong file đính kèm các bạn có thể bấm nút lệnh để lấy tên sheet, hoặc cũng có thể gõ hàm trực tiếp trên cell bằng cách quét chọn vài cell theo chiều dọc (A2:A20 chẳng hạn) rồi gõ lên thanh Formula công thức:
Em mạo muội thêm
tmp = tbItem.Name
tmp = Replace(tmp, "''", "'") tmp = Replace(tmp, "#", ".")
vào thì thấy OK thầy ạ.
Function rất tuyệt vời
Cảm ơn thầy.
Em mạo muội thêm
tmp = tbItem.Name
tmp = Replace(tmp, "''", "'") tmp = Replace(tmp, "#", ".")
vào thì thấy OK thầy ạ.
Function rất tuyệt vời
Cảm ơn thầy.
