Restrict rows

**Fineline** · 05-22-2013, 11:16 AM

Hello lovely forum people,

I would like to be able to limit the amount of rows that can be pasted in to a column then carry over the remainder to the next column and so on.

Example: I have 100 rows to paste into a sheet. I would like to limit the amount of rows to 30.
What I would like to happen is I paste my 100 rows of text into column A and I end up with 30 rows in column A B and C and 10 rows in column D.

Many Thanks
Paul

**p24leclerc** · 05-22-2013, 08:14 PM

You want to bypass the Excel COPY function. I don't think it can be done with regular events prgramming. I would recommend you to place a SPECIAL COPY button on your sheet that would trigger a macro to do it.
See attached file
Here is the macro:

Public Sub Special_Copy()
Dim R_ng As Range, C_ell As Range, Rng_Copy As Range, i As Integer
Dim No_row As Integer
Application.ScreenUpdating = False
Set R_ng = Selection
'Here you can change the number of rows you want to copy to
No_row = 30
i = 1 'Count number of rows copied
j = 1 'count columns filled
For Each C_ell In R_ng
  If i <= No_row Then
    If Rng_Copy Is Nothing Then
      Set Rng_Copy = C_ell
    Else
      Set Rng_Copy = Union(Rng_Copy, C_ell)
    End If
    i = i + 1
  Else
    Rng_Copy.Copy
    Cells(1, j).PasteSpecial
    j = j + 1
    Set Rng_Copy = C_ell
    i = 2
  End If
Next
Rng_Copy.Copy
Cells(1, j).PasteSpecial
If Not Intersect(R_ng, Range("A1", Cells(No_row, j))) Is Nothing Then
  Range(Cells(No_row + 1, R_ng.Column), R_ng(R_ng.Count, 1)).ClearContents
Else
  R_ng.ClearContents
End If
Range("A1").Select
Application.ScreenUpdating = True
End Sub

**Fineline** · 05-23-2013, 04:46 AM

Pierre,

You have revolutionised my working life. Saved me many many hours of monotonous copy and paste.

Merci beaucoup
Paul Hyland

**Fineline** · 05-23-2013, 06:53 AM

Hi Pierre (macro guru),

Is there a way to do the opposite?

I would like to take many columns with varying amounts of rows and put them all into one column.

Example: Column B has 10 rows of text Column C has 5 rows of text and Column D has 15 rows of text.
What I would like to happen is: I select columns B, C, and D, press the magic button and they all go in to column A.
B followed by C followed by D and so on.

So Colunm A would end up with with 30 rows, B followed by C followed by D and so on.

Many thanks
Paul

**p24leclerc** · 05-23-2013, 09:52 AM

There you are.

Public Sub Special_Copy()
Dim R_ng As Range
Application.ScreenUpdating = False
Set R_ng = Selection
'
For i = 1 To R_ng.Columns.Count
    Range(R_ng(1, i), Cells(Rows.Count, R_ng(1, i).Column).End(xlUp)).Select
    Selection.Copy
    If i = 1 Then
        Range("A" & Rows.Count).End(xlUp).PasteSpecial
    Else
        Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
    End If
    Application.CutCopyMode = False
Next
R_ng.ClearContents
'
Range("A1").Select
Application.ScreenUpdating = True
End Sub

**p24leclerc** · 05-24-2013, 06:30 PM

Here is another macro which is more flexible then the first one.

Public Sub Copy_Multiple_Columns()
'
'This macro copies data from multiple columns into one column
'
Dim R_ng As Range, I As Integer, J As Integer, K As Integer, Rng_1 As Range
Set R_ng = Application.InputBox("Select range of cells to copy to one column", Type:=8)
'Selection can be a single range even if some columnshave more data then others as long as there
'is no empty column in your range
'It could also be a multi range selection made with the CTRL key.
'
Set Rng_1 = Application.InputBox("Select column where to put all data", Type:=8)
'Select any cell in the column where you want the data to be copied to.
'Data will be copied to first row and down.
'Make sure this column is empty
'
Application.ScreenUpdating = False
'
K = 0 'Flag for the first data paste
For I = 1 To R_ng.Areas.Count
  If R_ng.Areas.Item(I).Columns.Count > 1 Then
    For J = 1 To R_ng.Areas.Item(I).Columns.Count
      If R_ng.Areas.Item(I).Cells(1, J) <> "" And R_ng.Areas.Item(I).Cells(R_ng.Areas.Item(I).Rows.Count, J) <> "" Then
        Range(R_ng.Areas.Item(I).Cells(1, J), R_ng.Areas.Item(I).Cells(R_ng.Areas.Item(I).Rows.Count, J)).Copy
      ElseIf R_ng.Areas.Item(I).Cells(1, J) = "" And R_ng.Areas.Item(I).Cells(R_ng.Areas.Item(I).Rows.Count, J) <> "" Then
        Range(R_ng.Areas.Item(I).Cells(1, J).End(xlDown), R_ng.Areas.Item(I).Cells(R_ng.Areas.Item(I).Rows.Count, J)).Copy
      ElseIf R_ng.Areas.Item(I).Cells(1, J) = "" And R_ng.Areas.Item(I).Cells(R_ng.Areas.Item(I).Rows.Count, J) = "" Then
        Range(R_ng.Areas.Item(I).Cells(1, J).End(xlDown), R_ng.Areas.Item(I).Cells(R_ng.Areas.Item(I).Rows.Count, J).End(xlUp)).Copy
      ElseIf R_ng.Areas.Item(I).Cells(1, J) <> "" And R_ng.Areas.Item(I).Cells(R_ng.Areas.Item(I).Rows.Count, J) = "" Then
        Range(R_ng.Areas.Item(I).Cells(1, J), R_ng.Areas.Item(I).Cells(R_ng.Areas.Item(I).Rows.Count, J).End(xlUp)).Copy
      End If
      Cells(Rows.Count, Rng_1.Column).End(xlUp).Offset(K, 0).PasteSpecial
      K = 1
      Application.CutCopyMode = False
    Next
  Else
    R_ng.Areas.Item(I).Copy
    Cells(Rows.Count, Rng_1.Column).End(xlUp).Offset(K, 0).PasteSpecial
    K = 1
  End If
Next
R_ng.ClearContents
'
Rng_1.Select
Application.ScreenUpdating = True
'
End Sub