Question

我之前发过关于我遇到的类似问题的帖子，但是遇到了新的挑战。如果发布一个新问题违反stackoverflow礼仪，则道歉。

我们拥有的是：一个电子表格中的四个工作簿（第1a层，第1b层，第1c层，第1层）

脚本需要：

剪切第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

请注意：＆＃34;要求代码的问题必须表明对要解决的问题的最小理解。包括尝试的解决方案，他们为什么没有工作，以及预期的结果。＆＃34; - 来自＆＃34; on-topic＆＃34;帮助页面。

因为这是一个很小的，可能是一次性的东西而且它是相对基础的我为你做的。但是将来取决于难度，可能难以得到答案。

这个宏做了一些假设：

1）没有空白（至少10行间隔不在tier1a中）

2）行数是tier1b，tier1c是tier1a的一半（因为你从tier1a获取前10个，而tier1b和tier1c只获得前5个）

3）当你说前10个单元格时，我假设你的意思是A列中的前10行

4）因为你说＆＃34; cut＆＃34;列a中的数据被复制和删除（与切割相同），使列留空，并且任何其他列不受影响。

如果您需要更加动态，或者如果您需要切割整行而不仅仅是列a

，请告诉我。

Excel - 将行剪切/粘贴到单独的工作簿宏中

2 个答案: