Dim i As Long, Leng As Long, rEnd As Long, m As Long
Dim Ktu As String, Gtri As String
On Error Resume Next
rEnd = [b100000].End(xlUp).Row
Leng = Len([a1])
If Leng > 6 Then
For i = 1 To Leng
Ktu = Right(Left([a1], i), 1)
If Ktu = ":" Then
m = i + 1
Exit For
End If
Next i
If m > 0 Then
Gtri = Left(Right([a1], Leng - m), Leng - m - 5)
For i = 8 To rEnd
If Cells(i, 1).Value = Gtri Then
Cells(i, 1).Select
Exit Sub
End If
Next i
End If
End Iftại mình làm gấp quá để tranh thủ đi làm, mình text trên máy của mình thì không thấy bị lỗi, còn phần "Back to Index" thì nó cũng giống tương tự như thằng hyperlink thôi, nếu bạn đợi được tới ngày mai mình mới gửi file update lên cho bạn nha!Dạ. gần đúng rồi ạ.
nhưng cần chỉnh lại cho đẹp như sau, vì khi chạy button "Hyperlink" trong sheet "Index", title không hiện lên được tương ứng title từng table sheet "Table".
[TABLE="width: 446"]
[TR]
[TD="colspan: 3"]#TABLE INDEX#[/TD]
[/TR]
[TR]
[TD]Table No[/TD]
[TD]Table Title[/TD]
[TD]Base[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]#TABLE INDEX#[/TD]
[TD]232[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]Table!A41[/TD]
[TD]232[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]Table!A99[/TD]
[TD]200[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]Table!A147[/TD]
[TD]215[/TD]
[/TR]
[/TABLE]
-> phải như vầy thì hay quá:
[TABLE="width: 446"]
[TR]
[TD="colspan: 3"]#TABLE INDEX#[/TD]
[/TR]
[TR]
[TD]Table No[/TD]
[TD]Table Title[/TD]
[TD]Base[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD] X3: ques1[/TD]
[TD]232[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]X4: Ques Temp 1[/TD]
[TD]150[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]X5: Ques Temp 5[/TD]
[TD]200[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]Ques Total[/TD]
[TD]215[/TD]
[/TR]
[/TABLE]
Và thay vì button "Back to Index" trên đầu sheet "Table" thì có thể chỉnh lại thành text "Back To Index" dưới mỗi table
Vì dụ: text "Back To Index" ở ô A4, A44, A102, A105
Cám ơn anh và mọi người vì đã dành thời gian giúp mình nhé
[TABLE="width: 408"]
[TR]
[TD="width: 408"]Cell Contents: <BR/>- Count<BR/ColumnPercentage<BR/>[/TD]
[/TR]
[/TABLE]Private Sub CommandButton1_Click()Dim i As Long, Leng As Long, rEnd As Long, m As Long, n As Long, k As Long
Dim Ktu As String, Gtri As String
On Error Resume Next
rEnd = Sheet2.[a100000].End(xlUp).Row
Sheet1.[a3].Resize(10000, 3).Clear
For n = 1 To rEnd
[COLOR=#ff0000] If Len(Sheet2.Cells(n, 1)) > 6 And Right(Sheet2.Cells(n, 1), 5) = "<BR/>" Then[/COLOR]
Leng = Len(Sheet2.Cells(n, 1))
If Leng > 6 Then
For i = 1 To Leng
m = 0
Ktu = Right(Left(Sheet2.Cells(n, 1), i), 1)
[COLOR=#ff0000] If Ktu = ":" Then[/COLOR]
m = i + 1
If m > 0 Then
k = k + 1
Gtri = Left(Right(Sheet2.Cells(n, 1), Leng - m), Leng - m - 5)
With Sheet1
.Cells(k + 2, 1) = k
.Cells(k + 2, 2) = Gtri
.Cells(k + 2, 2).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
"Table!A" & n & "", TextToDisplay:="" & Gtri & ""
.Cells(k + 2, 3) = Sheet2.Cells(n + 6, 2)
End With
End If
Exit For
End If
Next i
End If
End If
Next n
If k > 0 Then
rEnd = Sheet1.[b100000].End(xlUp).Row
With Sheet1.Range("a3:c" & rEnd)
.Borders.LineStyle = 1
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
End With
End If
End Sub
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
