英文:
Loop through rows of a table on outlook and change (Text To Display) to an ascending number per each row
问题
我已经使用以下代码循环遍历Outlook中的选择并将其转换为超链接，并更改显示的文本链接。
它有效，但会按照以下图片中的方式逐渐添加升序号码到所有单元格：
我的需求是按照每一行添加升序号码，就像这张图片一样：
提前感谢您的所有帮助。
Sub Hyperlink_Outlook()
Dim wDoc As Word.Document, rngSel As Word.Selection, cel As Cell, i As Long
Set wDoc = Application.ActiveInspector.WordEditor
Set rngSel = wDoc.Windows(1).Selection
If Not rngSel Is Nothing And rngSel.Information(wdWithInTable) Then
If rngSel.Range.Cells.Count > 0 Then
For Each cel In rngSel.Cells
If Len(cel.Range.Text) > 10 Then
i = i + 1
wDoc.Hyperlinks.Add cel.Range, _
Address:=Left(cel.Range.Text, Len(cel.Range.Text) - 1), _
TextToDisplay:="Attachment " & i
End If
Next
End If
End If
End Sub
英文:
I have used the below code to Loop through selection on outlook and convert into Hyperlinks and change Text To Display Link.
it works but it adds the the ascending number incrementally to all cells like this picture:
My need is to add the ascending number per each row like this picture:
In advance, great thanks for all your help.
Sub Hyperlink_Outlook()
Dim wDoc As Word.Document, rngSel As Word.Selection, cel As Cell, i As Long
Set wDoc = Application.ActiveInspector.WordEditor
Set rngSel = wDoc.Windows(1).Selection
If Not rngSel Is Nothing And rngSel.Information(wdWithInTable) Then
If rngSel.Range.Cells.Count > 0 Then
For Each cel In rngSel.Cells
If Len(cel.Range.Text) > 10 Then
i = i + 1
wDoc.Hyperlinks.Add cel.Range, _
Address:=Left(cel.Range.Text, Len(cel.Range.Text) - 1), _
TextToDisplay:="Attachment " & i
End If
Next
End If
End If
End Sub
答案1
得分: 2
尝试首先循环遍历行（以下内容未经测试）：
Sub Hyperlink_Outlook()
Dim wDoc As Word.Document, rngSel As Word.Selection, cel As Cell, i As Long
Dim r As Variant
Set wDoc = Application.ActiveInspector.WordEditor
Set rngSel = wDoc.Windows(1).Selection
If Not rngSel Is Nothing And rngSel.Information(wdWithInTable) Then
If rngSel.Range.Cells.Count > 0 Then
For Each r In rngSel.Rows
i = 0 ' 在此重置 i
For Each cel In r.Cells
If Len(cel.Range.Text) > 10 Then
i = i + 1
wDoc.Hyperlinks.Add cel.Range, _
Address:=Left(cel.Range.Text, Len(cel.Range.Text) - 1), _
TextToDisplay:="附件 " & i
End If
Next cel
Next r
End If
End If
End Sub
英文:
Try looping through rows first (the following is not tested):
Sub Hyperlink_Outlook()
Dim wDoc As Word.Document, rngSel As Word.Selection, cel As Cell, i As Long
Dim r As Variant
Set wDoc = Application.ActiveInspector.WordEditor
Set rngSel = wDoc.Windows(1).Selection
If Not rngSel Is Nothing And rngSel.Information(wdWithInTable) Then
If rngSel.Range.Cells.Count > 0 Then
For Each r In rngSel.Rows
i = 0 ' reset i here
For Each cel In r.Cells
If Len(cel.Range.Text) > 10 Then
i = i + 1
wDoc.Hyperlinks.Add cel.Range, _
Address:=Left(cel.Range.Text, Len(cel.Range.Text) - 1), _
TextToDisplay:="Attachment " & i
End If
Next cel
Next r
End If
End If
End Sub
答案2
得分: 2
请尝试以下适应的代码：
Sub Hyperlink_OutlookCols()
' Excel中的列必须自动调整列宽
Dim wDoc As Word.Document, rngSel As Word.Selection, cel As Word.Cell
Set wDoc = Application.ActiveInspector.WordEditor
Set rngSel = wDoc.Windows(1).Selection
If Not rngSel Is Nothing And rngSel.Information(wdWithInTable) Then
If rngSel.Range.Cells.count > 0 Then
For Each cel In rngSel.Cells
If Len(cel.Range.Text) > 10 Then
wDoc.Hyperlinks.Add cel.Range, _
Address:=Left(cel.Range.Text, Len(cel.Range.Text) - 1), _
TextToDisplay:="附件 " & cel.Column.Index
End If
Next cel
End If
End If
End Sub
您应该在自动调整各自列宽后从Excel中复制单元格...
英文:
Please, try the next adapted code:
Sub Hyperlink_OutlookCols()
'Columns in Excel must be autoFit
Dim wDoc As Word.Document, rngSel As Word.Selection, cel As Word.Cell
Set wDoc = Application.ActiveInspector.WordEditor
Set rngSel = wDoc.Windows(1).Selection
If Not rngSel Is Nothing And rngSel.Information(wdWithInTable) Then
If rngSel.Range.Cells.count > 0 Then
For Each cel In rngSel.Cells
If Len(cel.Range.Text) > 10 Then
wDoc.Hyperlinks.Add cel.Range, _
Address:=Left(cel.Range.Text, Len(cel.Range.Text) - 1), _
TextToDisplay:="Attachment " & cel.Column.Index
End If
Next cel
End If
End If
End Sub
You should copy the cells from Excel after autoFit the respective columns...
通过集体智慧和协作来改善编程学习和解决问题的方式。致力于成为全球开发者共同参与的知识库，让每个人都能够通过互相帮助和分享经验来进步。
评论