帖子: 60
主題: 20
精華: 0
積分: 87
點名: 0
作業系統: WinXP
軟體版本: Office 2007
閱讀權限: 20
性別: 男
註冊時間: 2011-8-4
最後登錄: 2020-5-25

1^# 跳轉到 » 倒序看帖

字體大小: tT

發表於 2011-10-14 14:08 | 只看該作者

[發問] (已解決)VBA 特定符號及文字設定程式請教

本帖最後由 wind6424 於 2011-10-14 16:32 編輯

想請教各位大大能幫忙看一下
下面VBA 那裡有問題,

我的目的是希望將儲存格中
[test1] 之前的文字變成藍色及字體加粗
然後每個[xxxx] 中括號內含括號及文字都設為黑色及加粗
其他的文字不變
這個程式在一開頭的文字是中文時執行都沒問題,
但是遇到開頭是英文或是數字時,
就會發生除了中括號內及文字是如設定的外
其它文字都變成藍色及加粗,
不知道是那裡還需要修改問題,
請各位前輩指導一下
謝謝

儲存格內容如下:
abscde
[test1]:
1.qwe
2.asd
[test2]:
qwe
[test3]:
sddf

VBA 程式:
With Sheet1.Cells(y, x)
      .Font.ColorIndex = 0
      .Font.Bold = False

      theText = .Text 'theText

      lngS = InStr(1, .Text, "[", 1) - 1

      .Characters(1, lngS).Font.ColorIndex = 5
      .Characters(1, lngS).Font.Bold = True

      Do While theText Like "*[[]*]*"

         lngS = InStr(lngS, .Text, "[")

         lngLen = VBA.InStr(lngS, .Text, "]") - lngS + 2

         .Characters(lngS, lngLen).Font.ColorIndex = 1
         .Characters(lngS, lngLen).Font.Bold = True

         lngS = lngS + lngLen
         theText = .Characters(lngS).Text

      Loop
End With

樓主熱帖

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

2^#

發表於 2011-10-14 15:03 | 只看該作者

回復 1# wind6424

Sub Ex()
Dim Y, X, A, A1
Y = 1: X = 1
Do While Sheet1.Cells(Y, X) <> ""
With Sheet1.Cells(Y, X)
.Font.ColorIndex = 0
.Font.Bold = False
A = InStr(.Text, "[")
A1 = InStr(.Text, "]")
If A > 0 And A1 > 0 Then
.Characters(A, A1 - A + 1).Font.ColorIndex = 5
.Characters(A, A1 - A + 1).Font.Bold = True
End If
Y = Y + 1
End With
Loop
End Sub

複製代碼

TOP

Hsieh

超級版主 Rank: 8 Rank: 8

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 91
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2024-4-19

2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

3^#

發表於 2011-10-14 15:11 | 只看該作者

Sub nn()
Dim A As Range, y%
For Each A In Range([A1], Cells(Rows.Count, 1).End(xlUp))
A.Font.Bold = False
A.Font.ColorIndex = 0
i = 1
Do Until Mid(A, i, 1) = "["
With A.Characters(i, 1).Font
.Bold = True
.ColorIndex = 5
End With
i = i + 1
Loop
s = InStr(A, "[")
y = InStr(s, A, "]")
Do Until s = 0
A.Characters(s + 1, y - s - 1).Font.Bold = True
s = InStr(y, A, "[")
If s > 0 Then y = InStr(s, A, "]")
Loop
Next
End Sub

複製代碼

回復 1# wind6424

學海無涯_不恥下問

TOP

wind6424

中學生 Rank: 2

帖子: 60
主題: 20
精華: 0
積分: 87
點名: 0
作業系統: WinXP
軟體版本: Office 2007
閱讀權限: 20
性別: 男
註冊時間: 2011-8-4
最後登錄: 2020-5-25

4^#

發表於 2011-10-14 16:21 | 只看該作者

本帖最後由 wind6424 於 2011-10-14 16:29 編輯

感謝兩位板主的協助
將兩位的程式碼結合
改成如下,實驗了一下 ok 了
在來將Cells(6, 8) 這個修改一下,就可以一次處理多個欄位了
非常的感謝

Sub test()
Dim A As Range, y%
Dim s
For Each A In Cells(6, 8)
A.Font.Bold = False
A.Font.ColorIndex = 0
s = InStr(A, "[")
y = InStr(s, A, "]")
A.Characters(1, s-1).Font.ColorIndex = 5
A.Characters(1, s-1).Font.Bold = True
Do Until s = 0
A.Characters(s + 1, y - s - 1).Font.Bold = True
s = InStr(y, A, "[")
If s > 0 Then y = InStr(s, A, "]")
Loop
Next
End Sub

複製代碼

TOP

Hsieh

超級版主 Rank: 8 Rank: 8

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 91
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2024-4-19

2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

5^#

發表於 2011-10-14 16:29 | 只看該作者

回復 4# wind6424

不對吧!
Cells(6,8)只針對H6此一儲存格

學海無涯_不恥下問

TOP

wind6424