Excel-將行剪切/粘貼到單獨的工作簿宏中

Question

我之前發布過有關我遇到的類似問題的信息，但遇到了新的挑戰。 抱歉，如果發布新問題有違Stackoverflow禮節。

我們擁有的是：在一個電子表格中的四個工作簿（1a，1b，1c，sheet1）

該腳本需要：

剪切1a層中的前10個單元格，然后粘貼到sheet1列A中，

切割第1b層中的前5個單元格，然后粘貼到sheet1的A列中，

剪切1c層的前5個單元格，然后粘貼到sheet1的A列中，

對每個工作簿中的所有單元格按降序重復-因此最終結果將在sheet1列A中具有10-5-5 10-5-5 10-5-5值等。

任何幫助，將不勝感激:)否則手動..請保存我的理智

Answer 1

這會起作用

Sub seperate()
Dim lrow As Long
Dim cn As Long
Dim rng As Range
Dim a1 As Integer
Dim b1 As Integer
Dim c1 As Integer

a1 = 0
b1 = 0
c1 = 0


lrow = Sheets("tier 1a").Range("A" & Rows.Count).End(xlUp).Row

cn = Round(lrow / 10)

For i = 0 To cn


lrow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
If lrow < 2 Then

With Sheets("tier 1a")
 .Range(.Cells(1, a1 + 1), .Cells(10, a1 + 1)).Copy Sheets("Sheet1").Range("A" & lrow + 1)
End With
With Sheets("tier 1b")

lrow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row

.Range(.Cells(1, b1 + 1), .Cells(5, b1 + 1)).Copy Sheets("Sheet1").Range("A" & lrow + 1)
End With
With Sheets("tier 1c")

lrow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row

.Range(.Cells(1, c1 + 1), .Cells(5, c1 + 1)).Copy Sheets("Sheet1").Range("A" & lrow + 1)
End With
a1 = a1 + 10
b1 = b1 + 5
c1 = c1 + 5

Else
With Sheets("tier 1a")

lrow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
'.Range(.Cells(a1 + 1, 1), .Cells(a1 + 1, 1).Offset(10, 0)).Select
.Range(.Cells(a1 + 1, 1), .Cells(a1 + 1, 1).Offset(9, 0)).Copy Sheets("Sheet1").Range("A" & lrow + 1)
End With

With Sheets("tier 1b")

lrow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row

.Range(.Cells(b1 + 1, 1), .Cells(b1 + 1, 1).Offset(4, 0)).Copy Sheets("Sheet1").Range("A" & lrow + 1)
End With
With Sheets("tier 1c")

lrow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row

.Range(.Cells(c1 + 1, 1), .Cells(c1 + 1, 1).Offset(4, 0)).Copy Sheets("Sheet1").Range("A" & lrow + 1)
End With

End If

Next


End Sub

Answer 2

我已經完成了一個簡單的循環，應該可以很好地處理這種情況：

Sub Macro1()

    Dim numrows As Long
    Sheets("tier 1a").Activate
    Range("A1").Activate
    While Not ActiveCell.FormulaR1C1 = "" 'will run untill a blank is encountered.

        On Error Resume Next
            'gets number of rows for sheet1 so as to paste after last row
            numrows = Sheets("Sheet1").Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
        On Error GoTo 0
        'copy A1 - A10 and paste on sheet1 in row after last used row
        Range(ActiveCell, ActiveCell.Offset(9, 0)).Copy Sheets("Sheet1").Cells(numrows + 1, 1)
        Range(ActiveCell, ActiveCell.Offset(9, 0)).Cells.Delete xlShiftUp 'delete copied cells

        'activate tier 1b, copy cells A1 - A5 and paste on sheet1.
        Sheets("tier 1b").Activate
        Range("A1", "A5").Cells.Copy Sheets("Sheet1").Cells(numrows + 11, 1) 'use numrows + 11 as 10 rows have been added without updating numrows
        Range("A1", "A5").Cells.Delete xlShiftUp 'delete copied cells


        'activate sheet tier 1c, copy cells a1 - a5 and paste on sheet1.
        Sheets("tier 1c").Activate
        Range("A1", "A5").Cells.Copy Sheets("Sheet1").Cells(numrows + 16, 1) 'use num rows + 16 because 15 rows have been pasted now without incrementing num rows.
        Range("A1", "A5").Cells.Delete xlShiftUp

        'activate tier 1a and go to cell a1
        Sheets("tier 1a").Activate 'move back to sheet tier1a and activate cell a1. if there is data, loop will run again in all 3 sheets
        Range("A1").Activate

    Wend

End Sub

請注意：“詢問代碼的問題必須對所解決的問題表現出最少的理解。包括嘗試的解決方案，為何行不通以及預期的結果。” -從“主題”幫助頁面開始。

由於這是一件很小的事情，可能只有1次，而且相對來說比較基礎，所以我為您做到了。 但將來，根據難度的高低，可能很難獲得答案。

該宏進行一些假設：

1）沒有空格（至少在10a行間隔中不在tier1a中）

2）行數是tier1b和tier1c的數量是tier1a的一半（因為您從tier1a中獲取前10個，而僅從tier1b和tier1c中獲取前5個）

3）當您說前10個單元格時，我假設您是指A列中的前10行

4）因為您說“剪切”列a中的數據被復制和刪除（與剪切相同），這使列空白，而其他列均未更改。

請讓我知道您是否需要使其更具動態性，或者是否需要剪切整行而不是僅刪除a列