Automatically copy over a range of cells if I type the heading of the column

[Sntrada]

Hi guys,

I am working on an excel sheet for a professor and I really need help. I have 75 columns in excel and each has a different heading which consists of three digits. The headings are all in row 32 of the sheet. All 75 columns have 30 rows of data which have a number in each cell. I am trying to come up with a formula (or something) where I can type the heading of a column (e.g 111) and have excel move the 30 cells which are directly underneath the heading, to a specific spot in the sheet.

 

[mrshl9898]

This works on you typing in the value you are after into a cell, then running the macro with that cell selected.

It will get everything from row 33 down under that heading, cut it and paste below your selected cell.

Sub movecellsunderactive()

Dim headingstring As String
Dim headingstringaddress As String
Dim colnum As Long

headingstring = ActiveCell.Value
headingstringaddress = ActiveCell.Address
colnum = 1

Do Until colnum = 73
If Cells(32, colnum).Value = headingstring Then
    Cells(32, colnum).Select
    ActiveCell.Offset(1, 0).Select
    Range(Selection, Selection.End(xlDown)).Cut
End If
colnum = colnum + 1
Loop

Range(headingstringaddress).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste

Application.CutCopyMode = False

End Sub

 

[Sntrada]

Sorry, the headings are in row 2, not row 32.

 

[Sntrada]

Thank you mrshl9898, I’ll try this!

 

[mrshl9898]

Just change to this if in Row 2.

Sub movecellsunderactive()

Dim headingstring As String
Dim headingstringaddress As String
Dim colnum As Long

headingstring = ActiveCell.Value
headingstringaddress = ActiveCell.Address
colnum = 1

Do Until colnum = 73
If Cells(2, colnum).Value = headingstring Then
    Cells(2, colnum).Select
    ActiveCell.Offset(1, 0).Select
    Range(Selection, Selection.End(xlDown)).Cut
End If
colnum = colnum + 1
Loop

Range(headingstringaddress).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste

Application.CutCopyMode = False

End Sub