Board logo

標題: [發問] 如何進行sheet1表不連續拷貝和回存資料? [打印本頁]
作者: luke    時間: 2012-4-19 21:19     標題: 如何進行sheet1表不連續拷貝和回存資料?

各位大大

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

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

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

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

煩請先進指導.

[attach]10516[/attach]
作者: register313    時間: 2012-4-19 23:43

回復 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    時間: 2012-4-20 15:37

回復 2# register313


謝謝R大多次協助

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

小弟錄製了乙個巨集Macro1

煩請先進 大大指導是否可以簡化程式內容
[attach]10536[/attach]
作者: register313    時間: 2012-4-20 16:28

回復 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    時間: 2012-4-20 22:14

回復 4# register313


    謝謝R大幫忙
作者: Hsieh    時間: 2012-4-20 22:36

回復 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    時間: 2012-4-20 23:30

回復 6# Hsieh


    謝謝H大

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

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

      煩請先進指導
作者: register313    時間: 2012-4-20 23:46

回復 7# luke


   Sheet1.Range("B:B").Borders.LineStyle = xlNone
作者: luke    時間: 2012-5-3 22:14

回復 6# Hsieh


    回覆H大

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

    煩請先進 指導修改程式
    [attach]10795[/attach]
作者: Hsieh    時間: 2012-5-3 22:53

回復 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
複製代碼




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