[發問] 如何進行sheet1表不連續拷貝和回存資料?

luke

各位大大

小弟想把sheet1表B欄中兩筆資料B1:B64和B101:B164內容

拷貝至sheet2表內所指定的特定儲存格即C:R欄做整理,

然後將sheet2這些特定儲存格內容回存至sheet1表原來的儲存格位置.

請問如何進行sheet1表不連續拷貝和回存資料?

煩請先進指導.

TEST11.rar (23.51 KB)

下載次數: 8

2012-4-19 21:19

register313

回復 1# luke

1. Sub 轉入()
   
2. Sheet2.Columns("C:R") = ""
   
3. For C = 1 To 4
   
4.   Sheet1.[B1:B16].Offset(16 * (C - 1), 0).Copy Sheet2.[C3].Offset(0, 5 * (C - 1))
   
5.   Sheet1.[B101:B116].Offset(16 * (C - 1), 0).Copy Sheet2.[C22].Offset(0, 5 * (C - 1))
   
6. Next C
   
7. Sheet2.[C11:C12,C26,C30:C31,C34].EntireRow.Insert
   
8. End Sub
   
9. Sub 轉出()
   
10. Dim AR()
    
11. I = 0
    
12. For X = 1 To 2
    
13.   If X = 1 Then
    
14.     Set Rng = Sheet2.[C3:C20]
    
15.     I = 0
    
16.   Else
    
17.     Set Rng = Sheet2.[C24:C43]
    
18.     I = 0
    
19.   End If
    
20.   For C = 1 To 4
    
21.     For Each A In Rng.Offset(0, 5 * (C - 1))
    
22.       If A.Value <> "" Then
    
23.         ReDim Preserve AR(I)
    
24.         AR(I) = A.Value
    
25.         I = I + 1
    
26.       End If
    
27.     Next
    
28.   Next C
    
29.   If X = 1 Then
    
30.     Sheet1.[B1].Resize(I, 1) = Application.Transpose(AR)
    
31.   Else
    
32.     Sheet1.[B101].Resize(I, 1) = Application.Transpose(AR)
    
33.   End If
    
34. Next X
    
35. End Sub

複製代碼

luke

回復 2# register313


謝謝R大多次協助

轉出資料OK,
但sheet2表 C:R欄有些儲存格有限制，因此轉入時不能清除內容

小弟錄製了乙個巨集Macro1

煩請先進 大大指導是否可以簡化程式內容
TEST11A.rar (20.22 KB)

下載次數: 2

2012-4-20 15:37

register313

回復 3# luke
程式前半段為儲存格複製(因儲存格位置變化太多,其他儲存格又不能更動,所以程式沒太大簡化)
程式後半段為儲存格框線之繪制

1. Sub 轉入()
   
2. Sheets("sheet1").Range("B1:B8").Copy Sheets("sheet2").Range("C3:C10")
   
3. Sheets("sheet1").Range("B9:B16").Copy Sheets("sheet2").Range("C13:C20")
   
4. Sheets("sheet1").Range("B17:B24").Copy Sheets("sheet2").Range("H3:H10")
   
5. Sheets("sheet1").Range("B25:B32").Copy Sheets("sheet2").Range("H13:H20")
   
6. Sheets("sheet1").Range("B33:B40").Copy Sheets("sheet2").Range("M3:M10")
   
7. Sheets("sheet1").Range("B41:B48").Copy Sheets("sheet2").Range("M13:M20")
   
8. Sheets("sheet1").Range("B49:B56").Copy Sheets("sheet2").Range("R3:R10")
   
9. Sheets("sheet1").Range("B57:B64").Copy Sheets("sheet2").Range("R13:R20")
   
10. Sheets("sheet1").Range("B101:B104").Copy Sheets("sheet2").Range("C24:C27")
    
11. Sheets("sheet1").Range("B105:B108").Copy Sheets("sheet2").Range("C29:C32")
    
12. Sheets("sheet1").Range("B109:B112").Copy Sheets("sheet2").Range("C35:C38")
    
13. Sheets("sheet1").Range("B113:B116").Copy Sheets("sheet2").Range("C40:C43")
    
14. Sheets("sheet1").Range("B117:B120").Copy Sheets("sheet2").Range("H24:H27")
    
15. Sheets("sheet1").Range("B121:B124").Copy Sheets("sheet2").Range("H29:H32")
    
16. Sheets("sheet1").Range("B125:B128").Copy Sheets("sheet2").Range("H35:H38")
    
17. Sheets("sheet1").Range("B129:B132").Copy Sheets("sheet2").Range("H40:H43")
    
18. Sheets("sheet1").Range("B133:B136").Copy Sheets("sheet2").Range("M24:M27")
    
19. Sheets("sheet1").Range("B137:B140").Copy Sheets("sheet2").Range("M29:M32")
    
20. Sheets("sheet1").Range("B141:B144").Copy Sheets("sheet2").Range("M35:M38")
    
21. Sheets("sheet1").Range("B145:B148").Copy Sheets("sheet2").Range("M40:M43")
    
22. Sheets("sheet1").Range("B149:B152").Copy Sheets("sheet2").Range("R24:R27")
    
23. Sheets("sheet1").Range("B153:B156").Copy Sheets("sheet2").Range("R29:R32")
    
24. Sheets("sheet1").Range("B157:B160").Copy Sheets("sheet2").Range("R35:R38")
    
25. Sheets("sheet1").Range("B161:B164").Copy Sheets("sheet2").Range("R40:R43")
    
26. With Sheets("sheet2").Range("C1:R43").Borders
    
27.   .LineStyle = xlContinuous
    
28.   .Weight = xlThin
    
29.   .ColorIndex = 0
    
30. End With
    
31. End Sub

複製代碼

luke

回復 4# register313


    謝謝R大幫忙

Hsieh

回復 5# luke
試試看

1. Sub 轉入()
   
2. With Sheet1
   
3.   r = 1: i = 3: k = 3
   
4.   Do Until r > 163
   
5.   .Cells(r, 2).Resize(IIf(r >= 65, 4, 8), 1).Copy Sheet2.Cells(i, k)
   
6.   If r = 65 Then
   
7.   r = 101
   
8.   Else
   
9.   r = r + IIf(r >= 65, 4, 8)
   
10.   End If
    
11.   If r <= 65 Then
    
12.      i = IIf(i = 3, 13, 3): k = IIf(i = 3, k + 5, k)
    
13.      ElseIf Int(((Int((r - 1) / 4) - 24) - 1) / 2) Mod 2 = 0 Then
    
14.      i = IIf(r = 101, 24, IIf(i = 24, 29, 24)): k = IIf(r = 101, 3, IIf(i = 24, k + 5, k))
    
15.      Else
    
16.      i = IIf(i = 29, 35, IIf(i = 35, 40, 35)): k = IIf(i = 24, k + 5, k)
    
17.   End If
    
18.   Loop
    
19. End With
    
20. End Sub
    
21. Sub 轉出()
    
22. Dim A As Range, C As Range
    
23. With Sheet2
    
24. Set A = Union(.[C3:R20], .[C24:R43])
    
25. For i = 1 To A.Areas.Count
    
26. r = IIf(i = 1, 1, 101)
    
27.    For j = 1 To 16 Step 5
    
28.    Set C = A.Areas(i).Columns(j).SpecialCells(xlCellTypeConstants)
    
29.    'C.Select
    
30.    C.Copy Sheet1.Cells(r, 3)
    
31.    r = r + C.Count
    
32.    Next
    
33. Next  
    
34. End With
    
35. End Sub

複製代碼

luke

回復 6# Hsieh


    謝謝H大

     第30列 應改為C.Copy Sheet1.Cells(r, 2)

     此外, sheet2表C1:R4, 若儲存格有格線,
     轉出到sheet1表B欄時, 如何消除格線

      煩請先進指導

register313

回復 7# luke


   Sheet1.Range("B:B").Borders.LineStyle = xlNone

luke

回復 6# Hsieh


    回覆H大

    執行"轉入"後, sheet2表W3:W62多出了4個如附件黃色區塊

    煩請先進 指導修改程式
    TEST11B.rar (18.48 KB)

下載次數: 3

2012-5-3 22:13

Hsieh

回復 9# luke

1. Sub 轉入()
   
2. Dim Rng As Range
   
3. With Sheet1
   
4. j = 3
   
5. For i = 1 To 57 Step 8
   
6. k = k + 1
   
7. r = IIf(k Mod 2 = 1, 3, 13)
   
8. Set Rng = .Cells(i, 2).Resize(8, 1)
   
9. Rng.Copy Sheet2.Cells(r, j)
   
10. j = IIf(r = 13, j + 5, j)
    
11. Next
    
12. j = 3
    
13. For i = 101 To 161 Step 4
    
14. k = k + 1
    
15. x = k Mod 4
    
16. r = IIf(x = 1, 24, IIf(x = 2, 29, IIf(x = 3, 35, 40)))
    
17. Set Rng = .Cells(i, 2).Resize(4, 1)
    
18. Rng.Copy Sheet2.Cells(r, j)
    
19. j = IIf(r = 40, j + 5, j)
    
20. Next
    
21. End With
    
22. End Sub

複製代碼