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列