Move all data from selected rows, into the top most selected row.

[Travis Kunnen]

Hi All

Another problem.

Im seeking a function or macro to move all the data from a selected series of rows, into the top most row of the selected area.
Example below. There are 12 rows of Romboutsia (84 to 95), and all rows will (/should) have 1 data point. Im looking to move all the data from the selected rows, into the top most row for this group. So the data from C87, needs to move into C84, D90 into D84, E93 into E84, etc etc...
There will never be two sets of data in the rows, for the same selected grouping of names from column A.
Then I can repeat the process for the next set, the Ruminococcus, and so on and so forth....

Macro Top 20.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M
84	Romboutsia	0,0872162
85	Romboutsia					0,02813
86	Romboutsia									0,03553
87	Romboutsia		0,077430923
88	Romboutsia						0,21361
89	Romboutsia										0,11849
90	Romboutsia			0,047901507
91	Romboutsia							0,032
92	Romboutsia											0,01558
93	Romboutsia				0,02124862
94	Romboutsia								0,02868
95	Romboutsia												0,0124
96	Ruminococcus	0,01897662
97	Ruminococcus		0,014345097
98	Ruminococcus			0,014001448
99	Ruminococcus							0,0106
Layer 1

 

[rpaulson]

try this on a copy for your file

Sub Do_it()

h_row = 84 'set the row to start with
r = h_row + 1

10
Data = Cells(h_row, "A")
If Data = "" Then Exit Sub 'no more data

If Data = Cells(r - 1, "A") Then 'found a match
    c = Cells(r, "A").End(xlToRight).Column
    Cells(h_row, c) = Cells(r, c)
Else
    h_row = r - 1 'set the row to start with
    r = h_row
End If

r = r + 1

GoTo 10

End Sub

hth,
Ross

 

[Travis Kunnen]

Hello

Thank you.
It copies, but it copies and moves more than the selected rows.

 

[rpaulson]

under its current state it will start at Cell A85 and continue down until it finds a blank cell in column A

is that not what you want?

 

[Travis Kunnen]

No.
In my example, rows 84 to 95 in column A are the genus Romboutsia. All the data within rows 84 to 95, I need to bring up to row 84, so that all the data in the rows with Romboutsia, are in now row 84.
Then the next genus, in rows 96 to 99 is Ruminococcus. All the data within rows 96 to 99 for Ruminococcus, need to be brought up into the first row for Ruminococcus, row 96.
This continues down for 1000's of rows of genus

The numerical data in the 'groupings of rows, ie 84-95, or 96-99, or etc the groupings of genus' rows cannot cross the genus row boundary, as that data belong to a different genus. Ie, the numerical data in cell C97 for Ruminococcus, cannot go into cell C84 for Romboutsia. It needs to stay in the 1st row for its respective grouping rows for that genus.

 

[rpaulson]

i found my glitch.

try this.

Sub Do_it()

h_row = 84
r = h_row + 1 'set the row to start with

10
genus = Cells(h_row, "A")

If genus = "" Then Exit Sub 'no more data

If Cells(r, "A") = genus Then  'found a match
    c = Cells(r, "A").End(xlToRight).Column
    Cells(h_row, c) = Cells(r, c)
    r = r + 1
Else
    h_row = r 'set the row to start with
    r = h_row + 1
End If

GoTo 10

End Sub

 

[Travis Kunnen]

Hi

Thank you. Yes it works!
It works even better than what I asked for, as it seems that it does the ENTIRE dataset at once. Instead of me having to do genus grouping selection at a time.
Fantastic, thank you again.

 

[rpaulson]

your welcome

 

[jolivanes]

Found this to be an interesting challenge.
I ran it on a small test and it worked but I don't know how it will work on a larger amount of data.
Would you be willing to try it and let us know?
If it has some definite nono's, maybe you, or anyone reading this, can let me know also.
I would think that the order in the "alldataArr" is important.

Sub Maybe_So()
Dim lr As Long, lc As Long, i As Long, j As Long
Dim dic As Object
Dim alldataArr, dataArr
lr = Cells(Rows.Count, 1).End(xlUp).Row
lc = Rows("5:" & lr).Find("*", , , , xlByColumns, xlPrevious).Column    '<----- Change the 5 to the actual starting Row
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = vbTextCompare
alldataArr = Range("A5:A" & lr).Value    '<----- Change the 5 to the actual starting Row
    For i = LBound(alldataArr) To UBound(alldataArr)
        If alldataArr(i, 1) <> "" Then dic(alldataArr(i, 1)) = Empty
    Next i
dataArr = dic.keys
For j = LBound(dataArr) To UBound(dataArr)
With ActiveSheet.Columns(1)
    With .Range(.Find(dataArr(j), , , 1, , 1), .Find(dataArr(j), , , 1, , 2))
        .Resize(, lc).SpecialCells(4).Delete Shift:=xlUp
        .Offset(1).Resize(.Rows.Count - 1).Delete Shift:=xlUp
    End With
End With
Next j
End Sub

 

[Travis Kunnen]

HI

Ok, so looks like your one also copies and pastes into the top most row, and then deletes the rows that have been copied from (?)
But it appears that it getting stuck at ".Offset(1).Resize(.Rows.Count - 1).Delete Shift:=xlUp", where the row only has 1 data value for the genus
See below:
So Abyssivirga, Acetanaerobacterium and Aerococcus in this small set have only one data point in the entire row. And there are other in the dataset that also have single data sets.

Abyssivirga						0,000962​
Acetanaerobacterium	0,000169434​
Acetivibrio	0,006523212​
Acetivibrio		0,01004165​
Acetivibrio			0,007208724​
Acetivibrio				0,043951​
Acetivibrio					0,033743​
Acetivibrio						0,015647​
Acetobacterium	0,006141986​
Acetobacterium		0,003138016​
Acetobacterium			0,006696429​
Acetobacterium				0,002076​
Acetobacterium					0,002618​
Acetobacterium						0,000513​
Acholeplasma	0,001355473​
Acholeplasma				0,00089​
Acholeplasma					0,000885​
Actinomyces	0,02122162​
Actinomyces		0,004792606​
Actinomyces			0,006806206​
Actinomyces				0,017304​
Actinomyces					0,042188​
Actinomyces						0,006349​
Aerococcus					0,000885​
Akkermansia	0,003049814​
Akkermansia		0,001996919​
Akkermansia			0,001353923​
Akkermansia				0,002126​