Code lấy tên sheet bỏ vào 1 file khác ?

[kydang1989]

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

 

[Let'GâuGâu]

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

không mở file thì chắc là phải xài ADO, cái này mình thua
thôi thì lén lén mở nó ra, lấy xong tên sheet rồi đóng nó lại

Sub MaHang(Optional sPath As Variant)
Dim WB As Workbook, sFile As String, WS As Worksheet, arr(), k As Long

Application.ScreenUpdating = False

If IsMissing(sPath) Then
    sPath = ThisWorkbook.Path 'ban hay khai báo l?i duong dan cho phu hop
    sFile = Dir(sPath & "\*.xlsx")
End If

Do While sFile <> ""
Set WB = Workbooks.Open(sFile)
For Each WS In Worksheets
    k = k + 1
    ReDim Preserve arr(1 To k)
    arr(k) = WS.Name
Next

WB.Close False

sFile = Dir()
Loop
[a2:a10000].Clear
[a2].Resize(k).Value = Application.WorksheetFunction.Transpose(arr)
Application.ScreenUpdating = True
End Sub

 

[ndu96081631]

không mở file thì chắc là phải xài ADO, cái này mình thua
thôi thì lén lén mở nó ra, lấy xong tên sheet rồi đóng nó lại

Sub MaHang(Optional sPath As Variant)
Dim WB As Workbook, sFile As String, WS As Worksheet, arr(), k As Long

Application.ScreenUpdating = False

If IsMissing(sPath) Then
    sPath = ThisWorkbook.Path 'ban hay khai báo l?i duong dan cho phu hop
    sFile = Dir(sPath & "\*.xlsx")
End If

Do While sFile <> ""
Set WB = Workbooks.Open(sFile)
For Each WS In Worksheets
    k = k + 1
    ReDim Preserve arr(1 To k)
    arr(k) = WS.Name
Next

WB.Close False

sFile = Dir()
Loop
[a2:a10000].Clear
[a2].Resize(k).Value = Application.WorksheetFunction.Transpose(arr)
Application.ScreenUpdating = True
End Sub

Rồi chạy code này bằng cách nào? Bạn đưa file + code lên xem thử
???!!!

 

[Let'GâuGâu]

Rồi chạy code này bằng cách nào? Bạn đưa file + code lên xem thử
???!!!

có gì sai hả anh? thấy nó ra kết quả mà?

 

[ndu96081631]

có gì sai hả anh? thấy nó ra kết quả mà?

Ủa? Vậy bạn đã chạy thử chưa?
Tôi không hiểu cái này nghĩa là gì:

Sub Workbook()
    [COLOR=#ff0000]MsgBox[/COLOR] ThisWorkbook.Path
End Sub

Nhưng nếu sửa chỗ màu đỏ thành MaHang thì báo lỗi

 

[kydang1989]

có gì sai hả anh? thấy nó ra kết quả mà?

sPath = ThisWorkbook.Path 'ban hay khai báo l?i duong dan cho phu hop

thay đường dẫn như thế nào vậy bạn?

 

[Let'GâuGâu]

Ủa? Vậy bạn đã chạy thử chưa?
Tôi không hiểu cái này nghĩa là gì:

Sub Workbook()
    [COLOR=#ff0000]MsgBox[/COLOR] ThisWorkbook.Path
End Sub

Nhưng nếu sửa chỗ màu đỏ thành MaHang thì báo lỗi

không hiểu ý anh, đoạn code trên để test gì vậy anh? sao lại thay "msgbox" thành "Mahang"?
à, hiểu rồi, đoạn code trong file đính kèm đó hả? cái đó quên xoá..............hehehehe

sPath = ThisWorkbook.Path 'ban hay khai báo l?i duong dan cho phu hop

thay đường dẫn như thế nào vậy bạn?

thì bạn khai báo cái đường dẫn chứa 2 file "mahang1" & "mahang2"
ví dụ

sPath="D:\myFolder"

 

[kydang1989]

thì bạn khai báo cái đường dẫn chứa 2 file "mahang1" & "mahang2"
ví dụ

sPath="D:\myFolder"

sao mình khai báo giống vậy rồi mà chạy vẫn lỗi, đã mở file mahang1 lên sao nó nói ko tìm thấy

nó tô màu vàng chỗ Set WB = Workbooks.Open(sFile)

 

[Let'GâuGâu]

sao mình khai báo giống vậy rồi mà chạy vẫn lỗi, đã mở file mahang1 lên sao nó nói ko tìm thấy

nó tô màu vàng chỗ Set WB = Workbooks.Open(sFile)

đó là đường dẫn của bạn hả?
chắc ko? tôi chỉ ví dụ thôi nha, tôi ko biết là file của bạn để ở đâu
bạn hãy mở "My computer" rồi đi đến file folder cuối cùng chứa "mahang1", "mahang2"
copy lại cái đường dẫn đó

với lại xem lại cái đuôi file nữa "xls" (2003) hay "xlsx"

 

[ndu96081631]

đó là đường dẫn của bạn hả?
chắc ko? tôi chỉ ví dụ thôi nha, tôi ko biết là file của bạn để ở đâu
bạn hãy mở "My computer" rồi đi đến file folder cuối cùng chứa "mahang1", "mahang2"
copy lại cái đường dẫn đó

với lại xem lại cái đuôi file nữa "xls" (2003) hay "xlsx"

Trên máy tôi cũng báo lỗi y chang vậy. Tôi nghĩ code này còn có chỗ nào đó bị sai (tôi không biết nữa)

 

[Let'GâuGâu]

sao mình khai báo giống vậy rồi mà chạy vẫn lỗi, đã mở file mahang1 lên sao nó nói ko tìm thấy

nó tô màu vàng chỗ Set WB = Workbooks.Open(sFile)

ừm sao kỳ hén, hồi chiều tôi test thấy nó chạy ngon lành rồi, tôi mới đưa lên
thử thêm lần nữa, ko được thì chạy luôn heheheh

Sub MaHang(Optional sPath As Variant)
Dim WB As Workbook, sFile As String, WS As Worksheet, arr(), k As Long

Application.ScreenUpdating = False

If IsMissing(sPath) Then
    sPath = ThisWorkbook.Path 'ban hay khai báo l?i duong dan cho phu hop
    sFile = Dir(sPath & "\" & "*.xlsx")
End If
Do While sFile <> ""
Set WB = Workbooks.Open[COLOR=#0000ff](sPath & "\" & sFile)[/COLOR]
For Each WS In Worksheets
    k = k + 1
    ReDim Preserve arr(1 To k)
    arr(k) = WS.Name
Next

WB.Close False

sFile = Dir()
Loop
[a2:a10000].Clear
[a2].Resize(k).Value = Application.WorksheetFunction.Transpose(arr)
Application.ScreenUpdating = True
End Sub

 

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

ừm sao kỳ hén, hồi chiều tôi test thấy nó chạy ngon lành rồi, tôi mới đưa lên
thử thêm lần nữa, ko được thì chạy luôn heheheh

Sub MaHang(Optional sPath As Variant)
Dim WB As Workbook, sFile As String, WS As Worksheet, arr(), k As Long

Application.ScreenUpdating = False

If IsMissing(sPath) Then
    sPath = ThisWorkbook.Path 'ban hay khai báo l?i duong dan cho phu hop
    sFile = Dir(sPath & "\" & "*.xlsx")
End If
Do While sFile <> ""
Set WB = Workbooks.Open[COLOR=#0000ff](sPath & "\" & sFile)[/COLOR]
For Each WS In Worksheets
    k = k + 1
    ReDim Preserve arr(1 To k)
    arr(k) = WS.Name
Next

WB.Close False

sFile = Dir()
Loop
[a2:a10000].Clear
[a2].Resize(k).Value = Application.WorksheetFunction.Transpose(arr)
Application.ScreenUpdating = True
End Sub

Bạn thử bỏ vào đường dẫn với tiếng Việt có dấu rồi chạy thử nhé.

 

[Quang_Hải]

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

Thử code này xem thế nào. Hình như không xử lý được sheet tên tiếng Việt có dấu.

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 Left(ObjFile.Name, 1) <> "~" Then
         If ObjFile <> ThisWorkbook.FullName Then
            Con.Open "dsn=excel files;dbq=" & 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

 

[Let'GâuGâu]

Thử code này xem thế nào. Hình như không xử lý được sheet tên tiếng Việt có dấu.

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 Left(ObjFile.Name, 1) <> "~" Then
         If ObjFile <> ThisWorkbook.FullName Then
            Con.Open "dsn=excel files;dbq=" & 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

anh QuangHai lúc này sử dụng ADO thượng thừa quá..............hehehehe
ADO đúng là bí hiểm quá, không giống code vba thông thường
làm sao mà biết được

[COLOR=#000000][COLOR=#0000BB]Set Cat [/COLOR][COLOR=#007700]= [/COLOR][COLOR=#0000BB]CreateObject[/COLOR][COLOR=#007700]([/COLOR][COLOR=#DD0000]"ADOX.Catalog"[/COLOR][COLOR=#007700])[/COLOR][/COLOR]

nó chứa list các sheet?
=============
à hình như 2 dòng lệnh này gán list các sheet vào cat.table, phải không anh?

Con.Open "dsn=excel files;dbq=" & ObjFile
            Cat.ActiveConnection = Con

 

[Quang_Hải]

anh QuangHai lúc này sử dụng ADO thượng thừa quá..............hehehehe
ADO đúng là bí hiểm quá, không giống code vba thông thường
làm sao mà biết được

[COLOR=#000000][COLOR=#0000BB]Set Cat [/COLOR][COLOR=#007700]= [/COLOR][COLOR=#0000BB]CreateObject[/COLOR][COLOR=#007700]([/COLOR][COLOR=#DD0000]"ADOX.Catalog"[/COLOR][COLOR=#007700])[/COLOR][/COLOR]

nó chứa list các sheet?
=============
à hình như 2 dòng lệnh này gán list các sheet vào cat.table, phải không anh?

Con.Open "dsn=excel files;dbq=" & ObjFile
            Cat.ActiveConnection = Con

Nói thật lòng là mình nhặt code của các thành viên trên diễn đàn rồi pha chế lại thôi, chứ không hiểu bản chất của nó đâu. Mấy cái này mình ít khi viết nên kém lắm.

 

[ndu96081631]

Đây là giải pháp của mình!

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

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

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:

=TRANSPOSE(GetSheets(FALSE,FilesFoldersList(LEFT(CELL("fileName",A3),FIND("[",CELL("fileName",A3))-1),TRUE, "*.xls",FALSE)))

Kết thúc bằng tổ hợp phím Ctrl + Shift + Enter
------------------------
Các bạn kiểm tra giúp mình, không biết còn chỗ nào không ổn hay không

 

[Kiều Mạnh]

Em Test Bài #16 Chạy Tốt

 

[Quang_Hải]

Xem xong code bài 16 muốn nhập viện luôn
Nếu ai nhát và né code bài 16 thì dùng code đơn giản này cũng chơi được tiếng việt có dấu.

Sub GetAllSheetNames()
Dim Fso As Object, ObjFile, sh
Dim Res(1 To 10000, 1 To 1), k As Long
Set Fso = CreateObject("Scripting.FileSystemObject")
With Fso.GetFolder(ThisWorkbook.Path)
   For Each ObjFile In .Files
      If Left(ObjFile.Name, 1) <> "~" Then
         If ObjFile <> ThisWorkbook.FullName Then
            With Workbooks.Open(ObjFile)
               For Each sh In ActiveWorkbook.Sheets
                 k = k + 1
                 Res(k, 1) = sh.Name
               Next
               .Close
            End With
         End If
      End If
   Next
End With
Sheets("MAHANG").[A2].Resize(k) = Res
End Sub

 

[Kiều Mạnh]

Xem xong code bài 16 muốn nhập viện luôn
Nếu ai nhát và né code bài 16 thì dùng code đơn giản này cũng chơi được tiếng việt có dấu.

Sub GetAllSheetNames()
Dim Fso As Object, ObjFile, sh
Dim Res(1 To 10000, 1 To 1), k As Long
Set Fso = CreateObject("Scripting.FileSystemObject")
With Fso.GetFolder(ThisWorkbook.Path)
   For Each ObjFile In .Files
      If Left(ObjFile.Name, 1) <> "~" Then
         If ObjFile <> ThisWorkbook.FullName Then
            With Workbooks.Open(ObjFile)
               For Each sh In ActiveWorkbook.Sheets
                 k = k + 1
                 Res(k, 1) = sh.Name
               Next
               .Close
            End With
         End If
      End If
   Next
End With
Sheets("MAHANG").[A2].Resize(k) = Res
End Sub

Em vừa Test thấy chạy Tốt Anh
Có lẻ thêm dòng sau nữa cho nó đỡ giật giật

Application.ScreenUpdating = True

 

[ndu96081631]

Xem xong code bài 16 muốn nhập viện luôn
Nếu ai nhát và né code bài 16 thì dùng code đơn giản này cũng chơi được tiếng việt có dấu.

Mở file trực tiếp là giải pháp đơn giản nhất nhưng sẽ rất phiền vì:
- File cần mở chứa vài chục ngàn objects, names hoặc stypes rác ---> Treo máy luôn
- Nếu file ta cần đang mở thì không cần mở nữa, nếu không code sẽ báo lỗi
- Phương pháp mở trực tiếp sẽ không thực hiện được với file đang bị lỗi
vân vân... và... mây mây. Ai mà biết cái gì trong trái ổi