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)没有空白(至少在10行间隔的tier1a中没有)

2)行数是tier1b，tier1c是tier1a的一半(因为您从tier1a中获取前10行，从tier1b和tier1c中仅获取前5行)

3)当您说前10个单元格时，我假设您指的是A列中的前10行

4)因为你说“剪切”，列a中的数据被复制和删除(与剪切相同)，这使得列为空白，而任何其他列保持不变。

如果您需要更动态，或者是否需要剪切整个行而不只是a列，请告诉我。