Copy values from right until non blank cell without impacting headers

[YasSheikh]

Hello Wizards!

Really hoping someone can help. Apologies if I break any forum rules. I am fairly new to VBA and have searched many threads but couldn't find anything for my problem.

Unable to post an example here but hopefully the below illustration helps. I am trying to copy data from the right until I hit the next header without impacting position of data based on headers. The problem is that the headers appear multiple times in the worksheet.

First header appears in Row3

Current state:

Header1	Header2		Header3		Header4	Header5
data	data				data
data			data			data
data	data		data
Header1	Header2	Header3	Header4		Header5
data	data		data		data
		data			data
data	data	data			data
	Header1	Header2		Header3	Header4	Header5
		data			data
	data	data				data
	data	data		data

Desired state:

Header1	Header2	Header3	Header4	Header5
data	data		data
data		data		data
data	data	data
Header1	Header2	Header3	Header4	Header5
data	data		data	data
		data		data
data	data	data		data
Header1	Header2	Header3	Header4	Header5
	data		data
data	data			data
data	data	data

I would be grateful if anyone is able to help!

 

[johnnyL]

With:

Book1
	A	B	C	D	E	F	G	H
1	Header1	Header2		Header3		Header4	Header5
2	data	data				data
3	data			data			data
4	data	data		data
5	Header1	Header2	Header3	Header4		Header5
6	data	data		data		data
7			data			data
8	data	data	data			data
9		Header1	Header2		Header3	Header4	Header5
10			data			data
11		data	data				data
12		data	data		data
13
Sheet5

How about:

Sub AlignHeaders()
'
    Dim LastColumnInRow As Long, LastRowInSheet As Long
    Dim ColumnCounter   As Long, RowCounter     As Long
'
    LastRowInSheet = Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row                                          ' Get last Row Number in sheet
    LastColumnInRow = Cells(1, Columns.Count).End(xlToLeft).Column                                                      ' Get last column nummber in row
'
    For RowCounter = 1 To LastRowInSheet Step 4                                                                         ' Loop through every 4th row
        For ColumnCounter = LastColumnInRow To 1 Step -1                                                                '   Loop backwards through column numbers
            If Cells(RowCounter, ColumnCounter) = vbNullString Then                                                     '       If cell is blank then ...
                Range(Cells(RowCounter, ColumnCounter), Cells(RowCounter + 3, ColumnCounter)).Delete Shift:=xlToLeft    '           Delete 4 cells in column
            End If
        Next                                                                                                            '   Loop back
    Next                                                                                                                ' Loop back
End Sub

 

[YasSheikh]

Hi JohnnyL

Thank you so much for your reply. Apologies, I should have been clearer. The length below each header isn't always 4 rows. These vary however there is always a blank line and then the next row of headers. Hopefully the below explains better:

Current state:

Header1	Header2		Header3		Header4	Header5
data	data				data
data			data			data
data						data
data	data		data
	data				data
Header1	Header2	Header3	Header4		Header5
data	data		data		data
		data			data
data	data	data			data
	data
		data
		data	data
	Header1	Header2		Header3	Header4	Header5
					data
	data	data				data
	data	data		data

Desired state:

Header1	Header2	Header3	Header4	Header5
data	data		data
data		data		data
data				data
data	data	data
	data
Header1	Header2	Header3	Header4	Header5
data	data		data	data
		data		data
data	data	data		data
	data
		data
		data	data
Header1	Header2	Header3	Header4	Header5
	data		data
data	data			data
data	data	data

Apologies again and thanks in advance!

 

[johnnyL]

Hi JohnnyL

Thank you so much for your reply. Apologies, I should have been clearer. The length below each header isn't always 4 rows. These vary however there is always a blank line and then the next row of headers.

That is going to be more difficult. Not impossible, just more difficult.

 

[johnnyL]

With:

ManyTests.xlsm
	A	B	C	D	E	F	G
1	Header1	Header2		Header3		Header4	Header5
2	data	data				data
3	data			data			data
4	data						data
5	data	data		data
6		data				data
7
8	Header1	Header2	Header3	Header4		Header5
9	data	data		data		data
10			data			data
11	data	data	data			data
12		data
13		data	data
14
15		Header1	Header2		Header3	Header4	Header5
16						data
17		data	data				data
18		data	data		data
Sheet5

How about:

Sub FindRowNumbersOfFirstBlankRowsAfterEachRangeOfDataInSheet()
'
    Dim BlankRowNumber                  As Long
    Dim ColumnCounter                   As Long, RowCounter     As Long
    Dim ColumnsWithValuesInRow          As Long
    Dim LastColumnNumberUsedInSheet     As Long, LastRowNumberUsedInSheet   As Long
    Dim StartRow                        As Long
    Dim FirstBlankRowInEachRangeList    As Object
    Dim FoundFirstRowInRange            As String
'
'--------------------------------------------------------------------------------------------------
'   Find Blank Rows in data range
'--------------------------------------------------------------------------------------------------
'
    Set FirstBlankRowInEachRangeList = CreateObject("System.Collections.ArrayList")         ' Establish 1D zero based arraylist called FirstBlankRowInEachRangeList
'
    LastRowNumberUsedInSheet = Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row            ' Get LastRowNumberUsedInSheet
    LastColumnNumberUsedInSheet = Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column   ' Get LastColumnNumberUsedInSheet
'
    FoundFirstRowInRange = "No"                                                                     ' Initialize FoundFirstRowInRange flag
'
    For BlankRowNumber = 1 To LastRowNumberUsedInSheet + 1                                          ' Loop to loop through each row in sheet
        ColumnsWithValuesInRow = WorksheetFunction.CountA(Range(Cells(BlankRowNumber, 1), _
            Cells(BlankRowNumber, LastColumnNumberUsedInSheet)))                                    '   Check each row for any values in the row
'
        If ColumnsWithValuesInRow > 0 And FoundFirstRowInRange = "No" Then                          '   If a value is found in the row & Not FoundFirstRowInRange flag
            FoundFirstRowInRange = "Yes"                                                            '       Set FoundFirstRowInRange flag = "Yes"
'
        ElseIf ColumnsWithValuesInRow = 0 And FoundFirstRowInRange = "Yes" Then                     '   Else if no values found in row & FoundFirstRowInRange = "Yes"
            FoundFirstRowInRange = "No"                                                             '       Set FoundFirstRowInRange flag = "No"
'
            FirstBlankRowInEachRangeList.Add BlankRowNumber                                         '       Append BlankRowNumber to FirstBlankRowInEachRangeList
        End If
    Next                                                                                            ' Loop back
'
'--------------------------------------------------------------------------------------------------
'   Delete cells in columns
'--------------------------------------------------------------------------------------------------
'
    StartRow = 1                                                                                    ' Initialize StartRow
'
    For RowCounter = 0 To FirstBlankRowInEachRangeList.Count - 1                                    ' Loop through list of Blank Rows
        For ColumnCounter = LastColumnNumberUsedInSheet To 1 Step -1                                '   Loop backwards through column numbers
            If Cells(StartRow, ColumnCounter) = vbNullString Then                                   '       If cell is blank then ...
                Range(Cells(StartRow, ColumnCounter), _
                  Cells((FirstBlankRowInEachRangeList(RowCounter) - 1), ColumnCounter)).Delete Shift:=xlToLeft  '           Delete cells in column
            End If
        Next                                                                                        '   Loop back
'
        StartRow = StartRow + (FirstBlankRowInEachRangeList(RowCounter) - StartRow) + 1             '   Increase StartRow
    Next                                                                                            ' Loop back
End Sub

This assumes your Row 1 is the starting row. If it isn't, adjust the StartRow = 1 line of code.

 

[YasSheikh]

Hi JohnnyL - you sir are an absolute lifesaver. Works like a charm. Cannot thank you enough for all your help!

 

[johnnyL]

Glad to help @YasSheikh.