Public Sub GPE()
Dim Rng As Range, Cll As Range, dArr(), I As Long, K As Long
With Sheets("Table")
Set Rng = .Range(.[A1], .[A1048576].End(xlUp))
ReDim dArr(1 To Rng.Rows.Count, 1 To 4)
For Each Cll In Rng
If InStr(UCase(Cll), "QUES") Then
K = K + 1
dArr(K, 1) = K
dArr(K, 2) = Left(Cll, InStr(UCase(Cll), "<") - 1)
dArr(K, 3) = Cll.Offset(6, 1)
dArr(K, 4) = Cll.Row
Cll.Offset(3).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
"Index!B2", TextToDisplay:="Back to Index"
End If
Next Cll
End With
Sheets.Add
With ActiveSheet
.Name = "Index"
.[B1] = "#TABLE INDEX#"
.[A2] = "Table No": .[B2] = "Table Title": .[C2] = "Base"
.[A3].Resize(K, 3) = dArr
.Columns("A:C").EntireColumn.AutoFit
For I = 1 To K
Range("B" & I + 2).Select
.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
"Table!A" & dArr(I, 4), TextToDisplay:=dArr(I, 2)
Next I
End With
Set Rng = Nothing
End SubDạ. Thanks anh nhiều. chạy smooth rồi anh.
Nhưng Anh ơi, key word "QUES" trong template file là em demo thôi. thật tế mỗi table, tên title khác nhau, vì dụ:
A1_1 : OCCASIONS TO DRINK<BR/>
Project xxxx
Table: 1<BR/>Level: Top
Do đó, dòng title (như điều kiện cũ, lấy hết, chỉ bỏ "<BR/>") em muốn lấy là trên dòng Project xxxx, có thể xem 2 key rows ở đây là:
Project xxxx
Table: xxx
bên cạnh đó, nếu đã có sheet "Index" rồi, thì anh bẫy giúp em: show 1 thông báo: "Sheet Index đã tồn tại. Bạn có muốn Overwrite không? Nếu Yes thì clear nội dung sheet Index và chạy macro bình thường, nếu không thì chương trình sẽ tạo ra thêm 1 sheet khác với tên "Index_1", tương tự, lần sau chạy nữa thì tạo thêm sheet "Index_2"...
****xong vụ trên, nếu em muốn phát triển thêm, ví dụ, trong file em có 3 sheets, thì khi chạy macro, sẽ tự tạo 3 sheets index: Index_1, Index_2, Index_3. Vậy có quá phức tạo không anh? Mong anh tư vấn cho em với
Em cám ơn anh và các pác trên forum đã dành thời gian cho đề tài của em vào ngày Chủ Nhật ạ
2/ Dò điều kiện dòng có "Project Test" chứ không phải "ques", tôi đã sửa bằng Code dưới.
Public Sub GPE()
Dim Ws As Worksheet, Rng As Range, Cll As Range, dArr(), I As Long, K As Long, DK As Boolean
On Error Resume Next
With Sheets("Table")
Set Rng = .Range(.[A1], .[A1048576].End(xlUp))
ReDim dArr(1 To Rng.Rows.Count, 1 To 4)
For Each Cll In Rng
If Cll.Value = "Project Test" Then
K = K + 1
dArr(K, 1) = K
dArr(K, 2) = Left(Cll.Offset(-1), InStr(Cll.Offset(-1), "<") - 1)
dArr(K, 3) = Cll.Offset(5, 1)
dArr(K, 4) = Cll.Offset(-1).Row
Cll.Offset(2).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
"Index!B2", TextToDisplay:="Back to Index"
End If
Next Cll
End With
For Each Ws In Worksheets
If Ws.Name = "Index" Then DK = True
Next Ws
If DK = False Then
Sheets.Add
ActiveSheet.Name = "Index"
End If
Sheets("Index").Select
With ActiveSheet
.[B1] = "#TABLE INDEX#"
.[A2] = "Table No": .[B2] = "Table Title": .[C2] = "Base"
.[A3:C1000].Clear
.[A3].Resize(K, 3) = dArr
.Columns("A:C").EntireColumn.AutoFit
For I = 1 To K
.Range("B" & I + 2).Select
.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
"Table!A" & dArr(I, 4), TextToDisplay:=dArr(I, 2)
Next I
End With
Set Rng = Nothing
End Sub
Dạ. Em cảm ơn anh. Em sẽ rút kinh nghiệm lần sau
Do ban đầu gấp quá nên chỉ capture những ý chính. càng về sau thì muốn tool hoàn thiện hơn nên phát sinh 1 số vấn đề khác.
Anh ơi, do bên em sau này sẽ có nhiều dự án với tên khác nhau, trong tình huống này em đặt "Project Test" (Do vấn đề bảo mật thông tin trong công ty nên em không tiện nêu rõ dự án đang làm). Vì vậy, anh sữa code giúp em chỉ dò "Project" và dòng dưới nó là "Table:" để xác định key word
A1_1 : OCCASIONS TO DRINK<BR/>
Project xxxx
Table: 1<BR/>Level: Top
-> để em chạy cho mọi dự án.
**Và khi click vào vị "Back To Index" của table đó trong sheet "Table", thì em muốn move qua sheet "Index" ngay tại vị trí link của table đó. Hiện tại thì con trỏ move lên dòng B2 của sheet "Index"
**Anh giúp em thêm code nếu trong file có nhiều sheet thì khi chạy macro sẽ tự tạo nhiều sheet "Index_1", "Index_2", tương ứng được không ạ?
Cám ơn anh trước
For Each Cll In Rng
If Cll.Value = "Project Test" Then '<-----Sửa dòng này thành: If Cll.Value Like "Project*" Then'
K = K + 1
Xử lý vấn đề này chỉ cần thêm vào một điều kiện giới hạn max chuỗi của nó là được
If Len(Sheet2.Cells(n, 1)) > 6 and [COLOR=#ff0000]Len(Sheet2.Cells(n, 1)) < 40[/COLOR] And Right(Sheet2.Cells(n, 1), 5) = "<BR/>" Then
