Board logo

標題: 儲存格每一列固定文字大小 [打印本頁]
作者: y663258    時間: 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
作者: kimbal    時間: 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
複製代碼
作者: y663258    時間: 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
作者: Hsieh    時間: 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
複製代碼
作者: y663258    時間: 2010-8-25 23:54

感謝hsieh 協助經測試完成符合需求，收下好好學習，以上感謝二位版主。
作者: GBKEE    時間: 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
複製代碼
作者: y663258    時間: 2010-8-26 08:37

謝謝二位協助再就教一個問題，換列間隔大小現是依上一列文字大小而定，可以做到自定換列間隔大小嗎?



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)