返回列表 上一主題 發帖

儲存格每一列固定文字大小

y663258

帖子
52 
主題
13 
精華
0 
積分
119 
點名
0  
作業系統
xp 
軟體版本
OFFICE 2003 
閱讀權限
20 
性別
男 
註冊時間
2010-5-6 
最後登錄
2022-6-7 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2010-8-25 16:50 | 只看該作者

儲存格每一列固定文字大小

各位先進:
              請幫忙更改以下程式碼，文字每列固定大小。謝謝
                  
Sub S()
Sheet1.Range("A1").Value = Space(4) & Sheet2.Range("A1") _
  & Chr(10) & Space(4) & Sheet2.Range("A2") _
  & Chr(10) & Space(4) & Sheet2.Range("A3") _
& Chr(10) & Space(4) & Sheet2.Range("A4") _
& Chr(10) & Space(4) & Sheet2.Range("A5") _
& Chr(10) & Space(4) & Sheet2.Range("A6") _

With Sheet1.Range("A1")
.Characters(1, 160).Font.Name = "標楷體" '因資料來源字數會增減，所以下方式不能讓
.Characters(1, 25).Font.Size = 22        '每一列固定文字大小,有其方式固定一列文字
.Characters(26, 46).Font.Size = 12       '大小
.Characters(47, 83).Font.Size = 16
.Characters(84, 106).Font.Size = 12
.Characters(107, 130).Font.Size = 16
.Characters(131, 150).Font.Size = 7
End With
End Sub

Book1.rar (7.3 KB)

收藏 分享

kimbal

帖子
472 
主題
5 
精華
0 
積分
485 
點名
0  
作業系統
Windows 
軟體版本
MS Office 
閱讀權限
100 
性別
男 
來自
香港 
註冊時間
2010-7-4 
最後登錄
2014-12-28 

論壇貢獻勳章
2#
發表於 2010-8-25 20:35 | 只看該作者
本帖最後由 kimbal 於 2010-8-25 20:39 編輯

回復 1# y663258

大約是這樣? 行數內大小寫死.
  1.      Dim strstr As Variant
  2.     Dim strstr as variant
  3.     Dim size As variant
  4.     size = array(22,12,16,12,16,7)
  5.     strstr = Sheet2.Range("A1:A6").Value
  6.    
  7.     If UBound(strstr) <= 0 Then
  8.         Exit Sub
  9.     End If
  10.       
  11.     Sheet1.Range("A1").Value = Space(4)
  12.     For i = 1 To UBound(strstr)
  13.         Sheet1.Range("A1").Value = Sheet1.Range("A1").Value & strstr(i, 1) & Chr(10) & Space(4)
  14.     Next
  15.     Sheet1.Range("A1").Value = Left(Sheet1.Range("A1").Value, Len(Sheet1.Range("A1").Value) - 5)
  16.     j = 4
  17.    
  18.     For i = 1 To UBound(strstr)
  19.         Sheet1.Range("A1").Characters(j, j + Len(strstr(i, 1)) + 5).Font.size = size(i)
  20.         j = j + Len(strstr(i, 1)) + 6
  21.     Next
複製代碼
懂得發問,答案就會在其中

今日の一秒は  明日にない
http://kimbalko-chi.blogspot.com
http://kimbalko.blogspot.com

TOP

y663258

帖子
52 
主題
13 
精華
0 
積分
119 
點名
0  
作業系統
xp 
軟體版本
OFFICE 2003 
閱讀權限
20 
性別
男 
註冊時間
2010-5-6 
最後登錄
2022-6-7 
3#
發表於 2010-8-25 23:11 | 只看該作者
感謝kimbal 版主大力協助測試後陣列索引超出範圍，可否再幫個忙修正。謝謝
      Sub h()
  Dim strstr As Variant

    Dim size As Variant
    size = Array(22, 12, 16, 12, 16, 7)
    strstr = Sheet2.Range("A1:A6").Value
   
    If UBound(strstr) <= 0 Then
        Exit Sub
    End If
      
    Sheet1.Range("A1").Value = Space(4)
    For i = 1 To UBound(strstr)
        Sheet1.Range("A1").Value = Sheet1.Range("A1").Value & strstr(i, 1) & Chr(10) & Space(4)
    Next
    Sheet1.Range("A1").Value = Left(Sheet1.Range("A1").Value, Len(Sheet1.Range("A1").Value) - 5)
    j = 4
   
    For i = 1 To UBound(strstr)
        Sheet1.Range("A1").Characters(j, j + Len(strstr(i, 1)) + 5).Font.size = size(i)
        j = j + Len(strstr(i, 1)) + 6
    Next
   
End Sub

TOP

Hsieh

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

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
4#
發表於 2010-8-25 23:36 | 只看該作者
回復 1# y663258
  1. Sub ex()
  2. ay = Array(22, 12, 16, 12, 16, 7)
  3. With Sheet2
  4. mystr = Join(Application.Transpose(.Range(.[A1], .[A65536].End(xlUp)).Value), Chr(10))
  5. ar = Split(mystr, Chr(10)): k = 0
  6. With Sheet1.Range("A1")
  7.    .Value = mystr
  8.    Do Until i = Len(mystr) Or k > UBound(ar)
  9.        i = i + 1
  10.        Do Until Mid(mystr, i, 1) = Chr(10) Or i > Len(mystr)
  11.           .Characters(i, 1).Font.Size = ay(k)
  12.           i = i + 1
  13.        Loop
  14.        k = k + 1
  15.    Loop
  16. End With
  17. End With
  18. End Sub
複製代碼
學海無涯_不恥下問

TOP

y663258

帖子
52 
主題
13 
精華
0 
積分
119 
點名
0  
作業系統
xp 
軟體版本
OFFICE 2003 
閱讀權限
20 
性別
男 
註冊時間
2010-5-6 
最後登錄
2022-6-7 
5#
發表於 2010-8-25 23:54 | 只看該作者
感謝hsieh 協助經測試完成符合需求，收下好好學習，以上感謝二位版主。

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
6#
發表於 2010-8-26 07:14 | 只看該作者
本帖最後由 GBKEE 於 2010-8-26 07:58 編輯

回復 3# y663258
Dim strstr As Variant     在有效範圍內 重復宣告   刪掉
size(i) 沒有減1              size的陣列會超出陣列的範圍 修正如下
Sheet1.Range("A1").Characters(j, j + Len(strstr(i, 1)) + 5).Font.size = size(i-1)

另外  j = j + Len(strstr(i, 1)) + 6         +6會超出1個字元  應是 +5 才正確
另一解法參考參考
  1. Sub Ex()   
  2. Dim Rng As Range, strstr As Variant, size As Variant, i%
  3.     Set Rng = Sheet2.Range("A1:A6")
  4.     size = Array(22, 12, 16, 12, 16, 7)
  5.     For i = 1 To Rng.Rows.Count
  6.         If Rng(i) <> "" Then
  7.             strstr = IIf(strstr <> "", strstr & Chr(10) & Space(4) & Rng(i), Space(4) & Rng(i))
  8.         End If
  9.     Next
  10.     If Len(strstr) < Rng.Rows.Count Then Exit Sub
  11.     Sheet1.Range("A1").Value = strstr
  12.     j = 4
  13.     For i = 1 To Rng.Rows.Count
  14.         If Rng(i) <> "" Then
  15.         Sheet1.Range("A1").Characters(j, j + Len(Rng(i))).Font.size = size(i - 1)
  16.        j = j + Len(Rng(i)) + 5
  17.        End If
  18.     Next
  19. End Sub
複製代碼

TOP

y663258

帖子
52 
主題
13 
精華
0 
積分
119 
點名
0  
作業系統
xp 
軟體版本
OFFICE 2003 
閱讀權限
20 
性別
男 
註冊時間
2010-5-6 
最後登錄
2022-6-7 
7#
發表於 2010-8-26 08:37 | 只看該作者
謝謝二位協助再就教一個問題，換列間隔大小現是依上一列文字大小而定，可以做到自定換列間隔大小嗎?

TOP

        靜思自在 : 有心就有福，有願就有力，自造福田，自得福緣。
返回列表 上一主題