Giúp mình tạo macro tạo mục lục

[tuan206791]

Em có gửi file kèm nhờ mọi người giúp giùm. Em cám ơn trước

 

[nghiaphuc]

Em có gửi file kèm nhờ mọi người giúp giùm. Em cám ơn trước

Tạm thời xài cái này nhé. Mình không đưa số trang vào mục lục nhưng bù lại, mình tạo 1 list các ca sĩ/nhóm nhạc, khi click vào sẽ liên kết tới vị trí tương ứng trên sheet dữ liệu.

Private Sub Worksheet_Activate()
    Dim Cll As Range
    [A2:A65536].ClearContents
    Set Cll = Sheet1.[A1]
    Do
        [A65536].End(3).Offset(1) = "=HYPERLINK(""[" & ThisWorkbook.Name & "]'" & _
            Sheet1.Name & "'!" & Cll.Address & """,""" & Cll.Value & """)"
        Set Cll = Cll.End(4).End(4).End(4)
    Loop Until Cll.Value = ""
End Sub

 

[tuan206791]

Tạm thời xài cái này nhé. Mình không đưa số trang vào mục lục nhưng bù lại, mình tạo 1 list các ca sĩ/nhóm nhạc, khi click vào sẽ liên kết tới vị trí tương ứng trên sheet dữ liệu.

Private Sub Worksheet_Activate()
    Dim Cll As Range
    [A2:A65536].ClearContents
    Set Cll = Sheet1.[A1]
    Do
        [A65536].End(3).Offset(1) = "=HYPERLINK(""[" & ThisWorkbook.Name & "]'" & _
            Sheet1.Name & "'!" & Cll.Address & """,""" & Cll.Value & """)"
        Set Cll = Cll.End(4).End(4).End(4)
    Loop Until Cll.Value = ""
End Sub

Mình muốn cho các đề mục ca sỹ hiện số trang bên cạnh chứ không cần tạo đường link tới từng ca sỹ, nên bạn sửa lại giúp mình tí

 

[nghiaphuc]

Mình muốn cho các đề mục ca sỹ hiện số trang bên cạnh chứ không cần tạo đường link tới từng ca sỹ, nên bạn sửa lại giúp mình tí

Chà chà, món này vậy mà khó gặm đấy. Hình như vụ này anh chàng Macro4 xử được đấy bạn. Xin nhờ các sư phụ Macro4 xuất chiêu giùm, chứ Macro4 thì em bó tay, bó cả hai chân luôn.

 

[tuan206791]

Vậy có ai biết thì giúp mình với nhé. thank!

 

[tuan206791]

đây là ví dụ cụ thể hơn thực sự cái này làm bằng tay thì hơi lâu nên bác nào biết thì giúp gìùm em. em up lên diễn đàn không đc nên đành up nhờ mediafire. mọi người thông cảm http://www.mediafire.com/?cndo7sagzz884dp

 

[nghiaphuc]

đây là ví dụ cụ thể hơn thực sự cái này làm bằng tay thì hơi lâu nên bác nào biết thì giúp gìùm em. em up lên diễn đàn không đc nên đành up nhờ mediafire. mọi người thông cảm http://www.mediafire.com/?cndo7sagzz884dp

Cuối cùng thì cũng "độ" được cái này, chạy chậm như con rùa nhưng cũng tới đích được (không biết gì về Macro4 thì ta xài VBA vậy!):

Sub TaoMucLuc()
    Dim Cll As Range, Pg As Integer, i As Integer
    
    'Application.ScreenUpdating = False'
    Sheet2.Activate: [A2:B65536].ClearContents
    Set Cll = Sheet1.[A1]: Pg = 1: i = 1
    Do
        [A65536].End(3).Offset(1) = "=HYPERLINK(""[" & ThisWorkbook.Name & "]'" & _
            Sheet1.Name & "'!" & Cll.Address & """,""" & Cll.Value & """)"
        Do
            If Sheet1.Rows(i).PageBreak <> xlNone Then Pg = Pg + 1
            i = i + 1
        Loop Until i > Cll.Row
        [A65536].End(3).Offset(, 1) = Pg
        Set Cll = Cll.End(4).End(4).End(4)
    Loop Until Cll.Value = ""
    With Range([A2], [B65536].End(3)).Font
        .Underline = False: .Color = 1
    End With
    'Application.ScreenUpdating = True'
End Sub

(nếu sheet dữ liệu có tới chữ Z thì cứ cho chạy Macro và đi uống cà phê nhé, chắc khi uống xong là máy cũng vừa hoàn tất...)

 

[tuan206791]

Cuối cùng thì cũng "độ" được cái này, chạy chậm như con rùa nhưng cũng tới đích được (không biết gì về Macro4 thì ta xài VBA vậy!):

Sub TaoMucLuc()
    Dim Cll As Range, Pg As Integer, i As Integer
    
    'Application.ScreenUpdating = False'
    Sheet2.Activate: [A2:B65536].ClearContents
    Set Cll = Sheet1.[A1]: Pg = 1: i = 1
    Do
        [A65536].End(3).Offset(1) = "=HYPERLINK(""[" & ThisWorkbook.Name & "]'" & _
            Sheet1.Name & "'!" & Cll.Address & """,""" & Cll.Value & """)"
        Do
            If Sheet1.Rows(i).PageBreak <> xlNone Then Pg = Pg + 1
            i = i + 1
        Loop Until i > Cll.Row
        [A65536].End(3).Offset(, 1) = Pg
        Set Cll = Cll.End(4).End(4).End(4)
    Loop Until Cll.Value = ""
    With Range([A2], [B65536].End(3)).Font
        .Underline = False: .Color = 1
    End With
    'Application.ScreenUpdating = True'
End Sub

(nếu sheet dữ liệu có tới chữ Z thì cứ cho chạy Macro và đi uống cà phê nhé, chắc khi uống xong là máy cũng vừa hoàn tất...)

sao minh chạy với file khác là báo lỗi bạn ạ, xem lại giúp mình với

 

[nghiaphuc]

sao minh chạy với file khác là báo lỗi bạn ạ, xem lại giúp mình với

Mình có biết cái "file khác" của bạn nó ra làm sao đâu mà xem. Nếu không ổn thì bạn cứ copy nguyên dữ liệu trên file kia vào sheet Du lieu trên file này xem sao, miễn là cấu trúc trên sheet giống với sheet Du lieu là được.

 

[sealand]

Bạn thử code này xem:

Option Explicit
Sub Xoa()
Sheet2.Range("A2:C" & Sheet2.[a65000].End(3).Row).ClearContents
End Sub
'****************************************************
Sub Dsach()
Dim i, j, n, V1, V2, Tr()
Dim Tm, Kq()
ReDim Kq(1 To 10000, 1 To 3)
Application.ScreenUpdating = False
V1 = ActiveSheet.Name
Sheet1.Select
V2 = ActiveWindow.View
ActiveWindow.View = xlPageBreakPreview
ReDim Tr(1 To Sheet1.HPageBreaks.Count)
For n = 1 To Sheet1.HPageBreaks.Count
Tr(n) = Sheet1.HPageBreaks(n).Location.Row
Next
With Sheet2
.[a2] = "LIST OF SONGS"
.[a3] = "No.": .[b3] = "Name": .[c3] = "Page No."
End With
Tm = Sheet1.Range("a1:c" & Sheet1.[a65000].End(3).Row)
For i = 1 To UBound(Tm, 1)
If Tm(i, 2) = "" And Tm(i, 1) <> "" Then
For n = 1 To Sheet1.HPageBreaks.Count
If i <= Tr(n) Then Exit For
Next
j = j + 1
Kq(j, 1) = j
Kq(j, 2) = Tm(i, 1)
Kq(j, 3) = "Trang " & n
End If
Next
Sheet2.[a4].Resize(10000, 3) = Kq
ActiveWindow.View = V2
Worksheets(V1).Select
End Sub

 

[tuan206791]

Mình có biết cái "file khác" của bạn nó ra làm sao đâu mà xem. Nếu không ổn thì bạn cứ copy nguyên dữ liệu trên file kia vào sheet Du lieu trên file này xem sao, miễn là cấu trúc trên sheet giống với sheet Du lieu là được.

mình coppy cái dữ liệu 300 trang của mình vào công nhận là nó chạy chậm quá, khoảng hơn 5 phút mới tìm ra số trang cho 1 ca sỹ, mà tổng số của mình lên tới 597 ca sỹ, như vậy thì lâu quá. Dù sao cũng cám ơn bạn nhiều vì mình cũng làm bạn mất nhiều thời gian.

 

[tuan206791]

Bạn thử code này xem:

Option Explicit
Sub Xoa()
Sheet2.Range("A2:C" & Sheet2.[a65000].End(3).Row).ClearContents
End Sub
'****************************************************
Sub Dsach()
Dim i, j, n, V1, V2, Tr()
Dim Tm, Kq()
ReDim Kq(1 To 10000, 1 To 3)
Application.ScreenUpdating = False
V1 = ActiveSheet.Name
Sheet1.Select
V2 = ActiveWindow.View
ActiveWindow.View = xlPageBreakPreview
ReDim Tr(1 To Sheet1.HPageBreaks.Count)
For n = 1 To Sheet1.HPageBreaks.Count
Tr(n) = Sheet1.HPageBreaks(n).Location.Row
Next
With Sheet2
.[a2] = "LIST OF SONGS"
.[a3] = "No.": .[b3] = "Name": .[c3] = "Page No."
End With
Tm = Sheet1.Range("a1:c" & Sheet1.[a65000].End(3).Row)
For i = 1 To UBound(Tm, 1)
If Tm(i, 2) = "" And Tm(i, 1) <> "" Then
For n = 1 To Sheet1.HPageBreaks.Count
If i <= Tr(n) Then Exit For
Next
j = j + 1
Kq(j, 1) = j
Kq(j, 2) = Tm(i, 1)
Kq(j, 3) = "Trang " & n
End If
Next
Sheet2.[a4].Resize(10000, 3) = Kq
ActiveWindow.View = V2
Worksheets(V1).Select
End Sub

Cám ơn anh sealand, code mà anh gửi cho em thì đã đc rồi anh ạ. Cám ơn vì sự quan tâm của anh

 

[sealand]

Giờ thì mình hiểu yêu cầu rồi, mình sửa lại code và test với gần 11.000 bài thỉ cũng không đến nỗi, chắc bạn không kịp làm gì .

 

[tuan206791]

Giờ thì mình hiểu yêu cầu rồi, mình sửa lại code và test với gần 11.000 bài thỉ cũng không đến nỗi, chắc bạn không kịp làm gì .

Anh sealand nhiệt tình quá, rất hài lòng với những gì anh đã giúp em.Cám ơn anh nhiều