Xin giúp em đọc tên sheet từ file excel khác (1 người xem)

[chuotpt3]

Em có 2 File Excel – Workbook1 sử dụng để ghi nhận các Tên gọi Sheet từ các File khác (ví dụ: từ Workbook2). Nhưng hiện tại em đang làm bằng tay – mà tình hình là có một số File có tới hơn 1000 Sheet – rất khó nhọc khi phải ghi nhận lại và bắt buộc phải rà soát / dò xem có thiếu sheet nào không?

Vậy em nhờ cả nhà mình giúp em như yêu cầu em ghi nhận bên trên với ạ

Em attach qua mail đây 2 file ví dụ để cả nhà mình tham khảo mà giúp em với.



Em chân thành cảm ơn
chuotpt3

 

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

Em có 2 File Excel – Workbook1 sử dụng để ghi nhận các Tên gọi Sheet từ các File khác (ví dụ: từ Workbook2). Nhưng hiện tại em đang làm bằng tay – mà tình hình là có một số File có tới hơn 1000 Sheet – rất khó nhọc khi phải ghi nhận lại và bắt buộc phải rà soát / dò xem có thiếu sheet nào không?

Vậy em nhờ cả nhà mình giúp em như yêu cầu em ghi nhận bên trên với ạ

Em attach qua mail đây 2 file ví dụ để cả nhà mình tham khảo mà giúp em với.



Em chân thành cảm ơn
chuotpt3

Thử dùng = DAO nhé:

[GPECODE=sql]Sub LayTenSheet()
Dim Dbs As Object, db As Object, tbl As Object, i As Integer
Set Dbs = CreateObject("DAO.DBEngine.36")
Set db = Dbs.OpenDatabase(ThisWorkbook.Path & "\Workbook2.xlsx", False, True, "Excel 8.0;")
i = 2
For Each tbl In db.TableDefs
i = i + 1
If Right(tbl.Name, 1) = "$" Or Right(tbl.Name, 2) = "$'" Then
Cells(i, 2) = tbl.Name
End If
Next tbl
db.Close
Set Dbs = Nothing: Set db = Nothing: Set tbl = Nothing

End Sub

[/GPECODE]

 

[ndu96081631]

Em có 2 File Excel – Workbook1 sử dụng để ghi nhận các Tên gọi Sheet từ các File khác (ví dụ: từ Workbook2). Nhưng hiện tại em đang làm bằng tay – mà tình hình là có một số File có tới hơn 1000 Sheet – rất khó nhọc khi phải ghi nhận lại và bắt buộc phải rà soát / dò xem có thiếu sheet nào không?

Vậy em nhờ cả nhà mình giúp em như yêu cầu em ghi nhận bên trên với ạ

Em attach qua mail đây 2 file ví dụ để cả nhà mình tham khảo mà giúp em với.



Em chân thành cảm ơn
chuotpt3

Bạn chép toàn bộ code dưới đây cho vào Module của Workbook1

Function wksNames(Optional ByVal FileName As String = "")
  Dim dao  As Object, db As Object, Arr()
  Dim i As Long, n As Long, lCount As Long, lVer As Long
  Dim tmp As String
  On Error Resume Next
  lVer = Val(Application.Version)
  If Len(FileName) = 0 Then FileName = ThisWorkbook.FullName
  Set dao = CreateObject("DAO.DBEngine." & IIf(lVer < 12, "36", "120"))
  Set db = dao.OpenDatabase(FileName, False, False, "Excel 8.0;")
  lCount = db.TableDefs.Count
  For i = 1 To lCount
    tmp = db.TableDefs(i - 1).Name
    tmp = Replace(tmp, "'", "")
    If Right(tmp, 1) = "$" Then
      n = n + 1
      ReDim Preserve Arr(1 To n)
      tmp = Left(tmp, Len(tmp) - 1)
      Arr(n) = tmp
    End If
  Next
  wksNames = Arr
  db.Close: Set dao = Nothing: Set db = Nothing
End Function
Sub Main()
  Dim vFile, Arr
  On Error Resume Next
  vFile = Application.GetOpenFilename("Excel Files, *.xls;*.xlsx;*.xlsm")
  If TypeName(vFile) = "String" Then
    Arr = wksNames(CStr(vFile))
    If IsArray(Arr) Then
      Range("B3:B10000").ClearContents
      Range("B3").Resize(UBound(Arr)).Value = WorksheetFunction.Transpose(Arr)
    End If
  End If
End Sub

Xong, bấm Alt + F8, chọn Sub Main để chạy code. Cửa sổ chọn file hiện ra, bạn cứ chọn file nào muốn lấy tên sheet rồi OK là được
Lưu ý: File Workbook1 phải được lưu theo định dạng xlsm nha
--------------------
Chưa từng thấy có file nào chứa 1000 sheet cả! Khiếp!

 

[ndu96081631]

Thử dùng = DAO nhé:

Sub LayTenSheet()
    Dim Dbs  As Object, db As Object, tbl As Object, i As Integer
    [COLOR=#ff0000][B]Set Dbs = CreateObject("DAO.DBEngine.36")[/B][/COLOR]
    Set db = Dbs.OpenDatabase(ThisWorkbook.Path & "\Workbook2.xlsx", False, True, "Excel 8.0;")
    i = 2
    For Each tbl In db.TableDefs
        i = i + 1
        If Right(tbl.Name, 1) = "$" Or Right(tbl.Name, 2) = "$'" Then
            Cells(i, 2) = tbl.Name
        End If
    Next tbl
    db.Close
    Set Dbs = Nothing: Set db = Nothing: Set tbl = Nothing
     
End Sub

Với dòng màu đỏ như trên thì sẽ cóc lấy được tên sheet đối với file xlsx, xlsm (chỉ áp dụng được đối với file xls thôi)

 

[chuotpt3]

Vâng, con cảm ơn Thầy ndu96081631 – có những Sheet tổng hợp như thế đấy Thầy ạ ... nên bọn con vất vả quá cơ ... Thành ra con phải cầu cứu thế này!!! Cũng cảm ơn Thầy Hai Lúa Miền Tây nữa ạ ... Con sẽ thử áp dụng xem sao!!!

 

[chuotpt3]

Con đã chạy thử file Thầy ndu96081631 chuyển – chạy ngon lành cành đào Thầy ạ ... Con cảm ơn Thầy lắm lắm
Đúng là nội dung của Thầy Hai Lúa Miền Tây không chạy được đối với các File .xlsx ... Con xin lỗi Thầy....

 

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

Với dòng màu đỏ như trên thì sẽ cóc lấy được tên sheet đối với file xlsx, xlsm (chỉ áp dụng được đối với file xls thôi)

Máy em test chạy bình thường nên mới post lên đó chứ, còn nếu không được thì dùng ado. Tuy nhiên nó sẽ thay đổi tí xíu về thứ tự tên sheet

[GPECODE=sql]Sub LayTenSheet_HLMT()
Dim cn As Object, cat As Object, tbl As Object, i As Integer
Set cn = CreateObject("ADODB.Connection")
Set cat = CreateObject("ADOX.Catalog")
Set tbl = CreateObject("ADOX.Table")
With cn
.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & ThisWorkbook.Path & "\Workbook2.xlsx" & _
";Extended Properties=""Excel 12.0;HDR=No;"";"
.Open
End With
cat.ActiveConnection = cn
i = 2
For Each tbl In cat.Tables
i = i + 1
If Right(tbl.Name, 1) = "$" Or Right(tbl.Name, 2) = "$'" Then
Cells(i, 2) = tbl.Name
End If
Next
cn.Close: Set cn = Nothing
Set cat = Nothing: Set tbl = Nothing

End Sub

[/GPECODE]

 

[ndu96081631]

Máy em test chạy bình thường nên mới post lên đó chứ, còn nếu không được thì dùng ado. Tuy nhiên nó sẽ thay đổi tí xíu về thứ tự tên sheet

Sub LayTenSheet_HLMT()
     Dim cn As Object, cat As Object, tbl As Object, i As Integer
       Set cn = CreateObject("ADODB.Connection")
       Set cat = CreateObject("ADOX.Catalog")
       Set tbl = CreateObject("ADOX.Table")
            With cn
                 .ConnectionString = "[B][COLOR=#ff0000]Provider=Microsoft.ACE.OLEDB.12.0[/COLOR][/B];" & _

                                     "Data Source=" & ThisWorkbook.Path & "\Workbook2.xlsx" & _
                                     ";Extended Properties=""Excel 12.0;HDR=No;"";"
                 .Open

            End With
            cat.ActiveConnection = cn
            i = 2
            For Each tbl In cat.Tables
                i = i + 1
                If Right(tbl.Name, 1) = "$" Or Right(tbl.Name, 2) = "$'" Then
                    Cells(i, 2) = tbl.Name
                End If
            Next
      cn.Close: Set cn = Nothing
      Set cat = Nothing: Set tbl = Nothing
       
  End Sub

Thì cũng vậy thôi
Chô màu đỏ sẽ không chơi được trên Excel 2003
(Nói chung là dùng ADO hay DAO gì cũng được nhưng phải phân biệt version)
-------------
Ngoài ra Hai Lúa đã test kỹ chưa? Code mới nhất vẫn còn sai: Kết quả cuối cùng có chứa dấu "$" hoặc dấu nháy cuối chuổi nhé

 

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

Thì cũng vậy thôi
Chô màu đỏ sẽ không chơi được trên Excel 2003
(Nói chung là dùng ADO hay DAO gì cũng được nhưng phải phân biệt version)

Do tác giả gửi file có định dạng .xlsx mà. Nếu muốn chạy hết thì thêm xử lý lỗi chút xíu là được chứ gì.

Còn dấu $' thì mình thêm hàm replace là được.

 

[ndu96081631]

Do tác giả gửi file có định dạng .xlsx mà. Nếu muốn chạy hết thì thêm xử lý lỗi chút xíu là được chứ gì.

Còn dấu $' thì mình thêm hàm replace là được.

Đã làm thì làm hoàn chỉnh cho người ta luôn chứ còn đợi gì nữa
Trên diễn đàn này, nói về rành ADO có mấy người? Hai Lúa nghĩ người ta TỰ SỬA được sao?
----------------------------------------
Code của tôi cũng còn sai ở vụ tên sheet có dấu nháy đơn (loại nháy đơn do người dùng tự đặt). Đang nghĩ cách sửa code đây!

 

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

Đã làm thì làm hoàn chỉnh cho người ta luôn chứ còn đợi gì nữa
Trên diễn đàn này, nói về rành ADO có mấy người? Hai Lúa nghĩ người ta TỰ SỬA được sao?
----------------------------------------
Code của tôi cũng còn sai ở vụ tên sheet có dấu nháy đơn (loại nháy đơn do người dùng tự đặt). Đang nghĩ cách sửa code đây!

Chỉ có thể loại bỏ dấu nháy cuối, dấu nháy đầu không thể bỏ được ngoại trừ dùng cách khác "ngoại đạo" để loại bỏ Thầy à.

 

[ndu96081631]

Chỉ có thể loại bỏ dấu nháy cuối, dấu nháy đầu không thể bỏ được ngoại trừ dùng cách khác "ngoại đạo" để loại bỏ Thầy à.

Tôi lấy ví dụ tên sheet người ta đặt thế này TG'01'BC
Tức cái nháy đơn ấy tự người ta đặt chứ không phải do code trả về <---- trường hợp này tính sao?
Còn cái vụ dấu nháy đầu và cuối thì dễ mà:
- Hể có dấu nháy đơn ở đầu thì đương nhiên sẽ có nháy đơn ở cuối. Trường hợp này thì TENSHEET = Mid(TENSHEET, 2, LEN(TENSHEET)-2) thôi
- Chú ý: Người dùng chỉ có thể đặt nháy đơn ở giữa tên sheet chứ họ không thể đặt nháy đơn vào đầu hay cuối (có muốn cũng chả được)

 

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

Tôi lấy ví dụ tên sheet người ta đặt thế này TG'01'BC
Tức cái nháy đơn ấy tự người ta đặt chứ không phải do code trả về <---- trường hợp này tính sao?
Còn cái vụ dấu nháy đầu và cuối thì dễ mà:
- Hể có dấu nháy đơn ở đầu thì đương nhiên sẽ có nháy đơn ở cuối. Trường hợp này thì TENSHEET = Mid(TENSHEET, 2, LEN(TENSHEET)-2) thôi
- Chú ý: Người dùng chỉ có thể đặt nháy đơn ở giữa tên sheet chứ họ không thể đặt nháy đơn vào đầu hay cuối (có muốn cũng chả được)

Thử dùng mid cũng không loại bỏ dấu nháy đơn ở đầu, còn dấu nháy đơn cuối thì dể rồi, mình chỉ replace "$'" của 2 ký tự ở phía cuối kết quả của tên sheet là được.

 

[ndu96081631]

Thử dùng mid cũng không loại bỏ dấu nháy đơn ở đầu, còn dấu nháy đơn cuối thì dể rồi, mình chỉ replace "$'" của 2 ký tự ở phía cuối kết quả của tên sheet là được.

Cái thằng "$" này cũng vậy nha: Coi chừng dùng Replace không xong! (vì người ta cũng có thể đặt tên sheet theo kiểu TG$$$BC$ và bác Bill cũng chẳng cằn nhằn gì

 

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

Cái thằng "$" này cũng vậy nha: Coi chừng dùng Replace không xong! (vì người ta cũng có thể đặt tên sheet theo kiểu TG$$$BC$ và bác Bill cũng chẳng cằn nhằn gì

Vậy thì mình xử lý lỗi, loại bỏ $: left=1 cho những anh không có nháy đơn và left = 2 cho những anh có nháy đơn.

 

[ndu96081631]

Vậy thì mình xử lý lỗi, loại bỏ $: left=1 cho những anh không có nháy đơn và left = 2 cho những anh có nháy đơn.

Tôi định làm thế này đây:

Function wksNames(Optional ByVal FileName As String = "")
  Dim dao  As Object, db As Object, Arr()
  Dim i As Long, n As Long, lCount As Long, lVer As Long
  Dim tmp As String
  On Error Resume Next
  lVer = Val(Application.Version)
  If Len(FileName) = 0 Then FileName = ThisWorkbook.FullName
  Set dao = CreateObject("DAO.DBEngine." & IIf(lVer < 12, "36", "120"))
  Set db = dao.OpenDatabase(FileName, False, False, "Excel 8.0;")
  lCount = db.TableDefs.Count
  For i = 1 To lCount
    tmp = db.TableDefs(i - 1).Name
    [COLOR=#ff0000]tmp = Replace(tmp, " ", "?")
    tmp = Replace(tmp, "'", " ")
    tmp = WorksheetFunction.Trim(tmp)
    tmp = Replace(tmp, " ", "'")
    tmp = Replace(tmp, "?", " ")[/COLOR]
    If Right(tmp, 1) = "$" Then
      n = n + 1
      ReDim Preserve Arr(1 To n)
      [COLOR=#0000cd]tmp = Left(tmp, Len(tmp) - 1)[/COLOR]
      Arr(n) = tmp
    End If
  Next
  wksNames = Arr
  db.Close: Set dao = Nothing: Set db = Nothing
End Function

Chổ màu đỏ để xử lý mấy thằng ku có dấu nháy đặt tùm lum ở giữa tên sheet
Hai Lúa kiểm tra xem còn chổ nào chưa ổn không
(Cái dấu "$" ấy thì đơn giản mà ---> Đoạn code màu xanh là được rồi)