y663258

帖子: 52
主題: 13
精華: 0
積分: 119
點名: 0
作業系統: xp
軟體版本: OFFICE 2003
閱讀權限: 20
性別: 男
註冊時間: 2010-5-6
最後登錄: 2022-6-7

1^# 跳轉到 » 正序看帖

打印

字體大小: tT

發表於 2011-1-19 12:02 | 只看該作者

程式碼修改

Dim i&, R As Range, Y%
i = 2: Y = 1
With Sheet2
Do While .Cells(i, "b") <> ""
Set R = .Cells(i, "b")
With Sheet1.Cells(i - 1, Y)
.Value = R & Chr(10) & R(1, 2) & R(1, 3) & R(1, 4) & Chr(10) & Chr(10) & R(1, 5) & Space(20) & R(1, 6) & "收" & Chr(10)
.ColumnWidth = 33
.Borders.LineStyle = xlContinuous
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.IndentLevel = 1
End With
If Y = 1 Then
Y = 1: i = i + 1
Else
Y = Y + 1
End If
Loop
End With
' Sheet1.PrintOut
End Sub

複製代碼

這程式碼是抄用其他大大所寫，我想改變資料寫入方式，1.原始方式是a1'b1'c1'''''向下寫入，可否改成a1,b1,c1,d1,e1,f1，再跳a2,b2,c2,d2,e2,f2。
2. R(1, 2)字大小10，R(1, 6)字大小14。自己想了許久就是無法達成，請先進幫忙。

樓主熱帖

y663258

中學生 Rank: 2

帖子: 52
主題: 13
精華: 0
積分: 119
點名: 0
作業系統: xp
軟體版本: OFFICE 2003
閱讀權限: 20
性別: 男
註冊時間: 2010-5-6
最後登錄: 2022-6-7

10^#

發表於 2011-1-21 08:55 | 只看該作者

謝謝Hsieh 版主，真是讓人讚佩，這樣就不受字數限制，跳行後該行字大小一致。

TOP

Hsieh

超級版主 Rank: 8 Rank: 8

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

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

9^#

發表於 2011-1-20 19:29 | 只看該作者

回復 8# y663258

Sub nn()
Dim a(6), Ar(), C As Range
r = 2
With Sheet2
Do Until .Cells(r, 2) = ""
For i = 0 To 5
a(i) = .Cells(r + i, 2) & Chr(10) & .Cells(r + i, 3)
Next
ReDim Preserve Ar(s)
Ar(s) = a
s = s + 1
r = r + 6
Loop
End With
With Sheet1.[A1].Resize(s, 6)
.Value = Application.Transpose(Application.Transpose(Ar))
For Each C In .Cells
C.Characters(1, InStr(C, Chr(10))).Font.Size = 12
C.Characters(InStr(C, Chr(10)), 256).Font.Size = 10
Next
End With
End Sub

複製代碼

學海無涯_不恥下問

TOP

y663258

中學生 Rank: 2

帖子: 52
主題: 13
精華: 0
積分: 119
點名: 0
作業系統: xp
軟體版本: OFFICE 2003
閱讀權限: 20
性別: 男
註冊時間: 2010-5-6
最後登錄: 2022-6-7

8^#

發表於 2011-1-20 16:54 | 只看該作者

再請教Hsieh大大程式中如何去設定Cells(r + i, 2)文字大小12"及Cells(r + i, 3)二個文字大小文字大小12"
謝謝

TOP

y663258

中學生 Rank: 2

帖子: 52
主題: 13
精華: 0
積分: 119
點名: 0
作業系統: xp
軟體版本: OFFICE 2003
閱讀權限: 20
性別: 男
註冊時間: 2010-5-6
最後登錄: 2022-6-7

7^#

發表於 2011-1-20 16:44 | 只看該作者

感謝hugh0620 Hsieh 二位大大幫助，祝福新年快樂。

TOP

hugh0620

　暱稱: VBA向前衝

高中生 Rank: 3 Rank: 3

帖子: 559
主題: 58
精華: 0
積分: 626
點名: 0
作業系統: win8
軟體版本: office2013
閱讀權限: 50
性別: 男
來自: TW
註冊時間: 2010-11-22
最後登錄: 2024-6-14

6^#

發表於 2011-1-20 16:35 | 只看該作者

回復 5# Hsieh

大大~ 你少漏了一個沒有寫到~
R(1, 2)字大小10，R(1, 6)字大小14 文字"李一"大小12"，"1111"大小10"
同一個儲存格上面的字要size=12 , 下面的字要size=10

學習才能提升自己

TOP

Hsieh

超級版主 Rank: 8 Rank: 8

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

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

5^#

發表於 2011-1-20 16:15 | 只看該作者

回復 3# y663258

Sub nn()
Dim a(6), Ar()
r = 2
With Sheet2
Do Until .Cells(r, 2) = ""
For i = 0 To 5
a(i) = .Cells(r + i, 2) & Chr(10) & .Cells(r + i, 3)
Next
ReDim Preserve Ar(s)
Ar(s) = a
s = s + 1
r = r + 6
Loop
End With
Sheet1.[A1].Resize(s, 6) = Application.Transpose(Application.Transpose(Ar))
End Sub

複製代碼

學海無涯_不恥下問

TOP

hugh0620

　暱稱: VBA向前衝

高中生 Rank: 3 Rank: 3

帖子: 559
主題: 58
精華: 0
積分: 626
點名: 0
作業系統: win8
軟體版本: office2013
閱讀權限: 50
性別: 男
來自: TW
註冊時間: 2010-11-22
最後登錄: 2024-6-14

4^#

發表於 2011-1-20 15:46 | 只看該作者

回復 3# y663258

新手~ 只有笨方法~ 不過測試是OK的~ 你可以試一下

  N = 0
For I = 1 To 2000
For J = 1 To 6
         Sheet1.Cells(I, J) = Sheet2.Range("B" & N + 2) & Chr(10) & Sheet2.Range("C" & N + 2)
         W1 = Len(Sheet2.Range("B" & N + 1))
         W2 = Len(Sheet2.Range("C" & N + 1))
      With Sheet1.Cells(I, J).Characters(Start:=1, Length:=W1).Font
         .Name = "新細明體"
         .FontStyle = "標準"
         .Size = 12
      End With
      With Sheet1.Cells(I, J).Characters(Start:=W1 + 1, Length:=W1 + 1 + W2).Font
         .Name = "新細明體"
         .FontStyle = "標準"
         .Size = 10
      End With
      N = N + 1
      If Sheet2.Range("B" & N + 2) = "" Then Exit Sub
Next
Next

學習才能提升自己

TOP

y663258