程式碼修改

y663258

1.     Dim i&, R As Range, Y%
   
2. 
   
3.     i = 2: Y = 1
   
4. 
   
5.     With Sheet2
   
6. 
   
7.         Do While .Cells(i, "b") <> ""
   
8. 
   
9.            Set R = .Cells(i, "b")
   
10. 
    
11.             With Sheet1.Cells(i - 1, Y)
    
12. 
    
13.                 .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)
    
14. 
    
15.                 .ColumnWidth = 33
    
16. 
    
17.                 .Borders.LineStyle = xlContinuous
    
18. 
    
19.                 .HorizontalAlignment = xlLeft
    
20. 
    
21.                 .VerticalAlignment = xlCenter
    
22. 
    
23.                 .IndentLevel = 1
    
24. 
    
25.              End With
    
26. 
    
27.             If Y = 1 Then
    
28. 
    
29.              Y = 1: i = i + 1
    
30. 
    
31.             Else
    
32. 
    
33.                 Y = Y + 1
    
34. 
    
35.             End If
    
36. 
    
37.         Loop
    
38. 
    
39.     End With
    
40. 
    
41.   '  Sheet1.PrintOut
    
42. 
    
43. 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

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

Hsieh

回復 8# y663258

1. Sub nn()
   
2. Dim a(6), Ar(), C As Range
   
3. r = 2
   
4. With Sheet2
   
5. Do Until .Cells(r, 2) = ""
   
6.    For i = 0 To 5
   
7.       a(i) = .Cells(r + i, 2) & Chr(10) & .Cells(r + i, 3)
   
8.    Next
   
9.    ReDim Preserve Ar(s)
   
10.    Ar(s) = a
    
11.    s = s + 1
    
12.    r = r + 6
    
13. Loop
    
14. End With
    
15. With Sheet1.[A1].Resize(s, 6)
    
16. .Value = Application.Transpose(Application.Transpose(Ar))
    
17. For Each C In .Cells
    
18.    C.Characters(1, InStr(C, Chr(10))).Font.Size = 12
    
19.    C.Characters(InStr(C, Chr(10)), 256).Font.Size = 10
    
20. Next
    
21. End With
    
22. End Sub

複製代碼

y663258

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

y663258

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

hugh0620

回復 5# Hsieh


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

Hsieh

回復 3# y663258

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

複製代碼

hugh0620

回復 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

y663258

附上檔案請大家幫忙囉! 100.zip (5.51 KB)

下載次數: 9

2011-1-19 16:01

hugh0620

回復 1# y663258


    建議是否貼個範例~ 會使大大們比較清楚你真正的需求是什麼~
    這樣會比較快幫你解決你的問題唷~~^^