Excel - cut/paste rows into separate workbooks macro

Question

I posted earlier about a similar problem I am having, but have a new challenge. Apologies if posting a new question goes against stackoverflow etiquette.

What we have is: four workbooks in one spreadsheet (tier 1a, tier 1b, tier 1c, sheet1)

The script needs to:

Cut the first 10 cells in tier 1a and paste into sheet1 column A,

Cut the first 5 cells in tier 1b and paste into sheet1 column A,

Cut the first 5 cells in tier 1c and paste into sheet1 column A,

Repeat in descending order for all cells in each workbook - so the end result will have 10-5-5 10-5-5 10-5-5 values etc. in sheet1 column A

Any help would be greatly appreciated :) otherwise manual it is.. please save my sanity

Answer 1

This will work

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

I've done up a simple loop that should work adequetly for this situation:

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

please do note that: "Questions asking for code must demonstrate a minimal understanding of the problem being solved. Include attempted solutions, why they didn't work, and the expected results." - from the "on-topic" help page.

Since this was a small, probably 1 time thing and it was relatively basic I made it for you. but in future depending on the level of difficulty it may be difficult getting an answer.

This macro makes a few assumptions:

1)there are no blanks (at least not in tier1a at the 10 row intervals)

2)the number of rows is tier1b and tier1c are half as many as tier1a (because you're taking the first 10 from tier1a and only the first 5 from tier1b and tier1c)

3)when you say first 10 cells, I assume you mean first 10 rows in column A

4)because you say "cut" the data in column a is copied and deleted(same as cutting) which leaves column a blank, and any other colums untouched.

please let me know if you need this to be more dynamic, or if you need the entire row to be cut instead of just column a