Finding 1st Blank Cell in a Column, and then Copying data in adjacent columns

[MB95]

Hello, will start off by saying I am extremely new to VBA so I appreciate the patience beforehand.

1) I am currently attempting to search "Column A" to find the first blank cell row (highlighted red) in "Column A" which then has data in the next 5 columns (highlighted light red).

2) I am then attempting to take the data in "Columns B:F" and paste/offset into the destination marked with the purple borders.

This below screenshot shows an example of what I am working with on a smaller scale as my original file is thousands rows long.

My current code enables me to find the blank cells in "Column A" (highlighted blue) but I am at a loss to begin figuring out how to copy the data adjacent to it.

Sub test2()

Dim sourceCol As Integer, rowCount As Integer, currentRow As Integer
Dim currentRowValue As String

sourceCol = 1

rowCount = cells(Rows.Count, sourceCol).End(xlUp).Row

    For currentRow = 1 To rowCount
        currentRowValue = cells(currentRow, sourceCol).Value
        If IsEmpty(currentRowValue) Or currentRowValue = "" Then
            cells(currentRow, sourceCol).Interior.ColorIndex = "17"
        End If
    
    Next
    
End Sub

Thanks!

 

[johnnyL]

This is one way of doing it:

Sub test2a()
'
    Dim sourceCol As Integer, rowCount As Integer, currentRow As Integer
    Dim currentRowValue As String
'
    sourceCol = 1
'
    rowCount = Cells(Rows.Count, sourceCol).End(xlUp).Row

    For currentRow = 1 To rowCount + 1                                  ' <--- +1 to account for last row being blank in A column, but data in columns to the right
        currentRowValue = Cells(currentRow, sourceCol).Value
        If IsEmpty(currentRowValue) Or currentRowValue = "" Then
            Cells(currentRow, sourceCol).Interior.ColorIndex = "17"
            Range("H" & currentRow - 1 & ":L" & currentRow - 1).Value = Range("B" & currentRow & ":F" & currentRow).Value
        End If
    Next
End Sub

It could be done using offset as well.

 

[MB95]

Thank you for this! This got me pretty close to exactly what I need. This just leads to one more question.

I have tweaked the code slightly to clear the contents of the range "Columns B:F" that I wanted to copy/paste one row above to "Columns H:L" as shown below. Also to change the NumberFormat to "mm/dd/yyyy" throughout "Column K".

Before:

After:

Code Used:

Sub test2a()
'
    Dim sourceCol As Integer, rowCount As Integer, currentRow As Integer
    Dim currentRowValue As String
'
    sourceCol = 1
'
    rowCount = Cells(Rows.Count, sourceCol).End(xlUp).Row

    For currentRow = 1 To rowCount
        currentRowValue = Cells(currentRow, sourceCol).Value
        
        If IsEmpty(currentRowValue) Or currentRowValue = "" Then
            Range("H" & currentRow - 1 & ":L" & currentRow - 1).Interior.ColorIndex = "17"
            Range("H" & currentRow - 1 & ":L" & currentRow - 1).Value = Range("B" & currentRow & ":F" & currentRow).Value '<--- completes copy & paste
        
        End If
                
        If IsEmpty(currentRowValue) Or currentRowValue = "" Then
            Range("A" & currentRow).EntireRow.ClearContents

End If

Next

Columns("K").NumberFormat = "mm/dd/yyyy"

End Sub

What I would like to do now is remove the rows which are blank after completing the copy/paste & the clearing of contents. The issue I run into is that the data in cells "H17:L17" in the prior screenshot get deleted when I try to use "EntireRow.Delete" when added to the code above (marked in Red in the following screenshot).

Code Used (to attempt to delete blank rows):

Sub test2a()
'
    Dim sourceCol As Integer, rowCount As Integer, currentRow As Integer
    Dim currentRowValue As String
'
    sourceCol = 1
'
    rowCount = Cells(Rows.Count, sourceCol).End(xlUp).Row

    For currentRow = 1 To rowCount
        currentRowValue = Cells(currentRow, sourceCol).Value
        
        If IsEmpty(currentRowValue) Or currentRowValue = "" Then
            Range("H" & currentRow - 1 & ":L" & currentRow - 1).Interior.ColorIndex = "17"
            Range("H" & currentRow - 1 & ":L" & currentRow - 1).Value = Range("B" & currentRow & ":F" & currentRow).Value '<--- completes copy & paste
        
        End If
                
        If IsEmpty(currentRowValue) Or currentRowValue = "" Then
            Range("A" & currentRow).EntireRow.ClearContents
        
        End If

        If IsEmpty(currentRowValue) Or currentRowValue = "" Then
            Range("A" & currentRow).EntireRow.Delete

        End If
    
    Next
    
Columns("K").NumberFormat = "mm/dd/yyyy"
                                                                        
End Sub

Thanks once again!!!!

 

[johnnyL]

How about this:

Sub test2b()
'
    Dim sourceCol As Integer, rowCount As Integer, currentRow As Integer
    Dim currentRowValue As String
'
    sourceCol = 1                                                           ' Column A
'
    rowCount = Cells(Rows.Count, sourceCol).End(xlUp).Row

    For currentRow = rowCount + 1 To 1 Step -2                                 ' <--- +1 to account for last row being blank in A column, but data in columns to the right
        currentRowValue = Cells(currentRow, sourceCol).Value
        If IsEmpty(currentRowValue) Or currentRowValue = "" Then
            Range("H" & currentRow - 1 & ":L" & currentRow - 1).Value = Range("B" & currentRow & ":F" & currentRow).Value
            Rows(currentRow).EntireRow.Delete                        ' Delete current row that was copied to previous row
        Else
            currentRow = currentRow + 1
        End If
    Next
'
    Columns("K").NumberFormat = "mm/dd/yyyy"
End Sub

 

[Peter_SSs]

@MB95
First a some comments

• vba converts all Integer variables to type Long before using them so you might as well declare them as long to start with (it is shorter to type anyway )
• Instead of testing every row for blank** in column A, we should be able to more directly target those cells. Unless your data is very large, you won't see the difference in execution time, but it just seems more efficient to me.
• It also seems more efficient to delete all the unwanted rows at once rather than one at a time.
• Especially when deleting rows, turning screen updating off will speed the code and make it easier on the eyes.

** From your code it is unclear whether the 'blank' cells in column A are actually blank or contain a null string "", or perhaps some of each. The code below assumes they are blank but if that is not the case, we should be able to adapt the code if you are interested in this method.

Test with a copy of your data.

Sub Rearrange()
  Dim rBlank As Range, c As Range
  
  Set rBlank = Range("A1:A" & Range("B" & Rows.Count).End(xlUp).Row).SpecialCells(xlBlanks)
  Application.ScreenUpdating = False
  For Each c In rBlank
    c.Offset(-1, 7).Resize(, 5).Value = c.Offset(, 1).Resize(, 5).Value
  Next c
  rBlank.EntireRow.Delete
  Columns("K").NumberFormat = "mm/dd/yyyy"
  Application.ScreenUpdating = True
End Sub

 

[MB95]

@MB95
First a some comments

• vba converts all Integer variables to type Long before using them so you might as well declare them as long to start with (it is shorter to type anyway )
• Instead of testing every row for blank** in column A, we should be able to more directly target those cells. Unless your data is very large, you won't see the difference in execution time, but it just seems more efficient to me.
• It also seems more efficient to delete all the unwanted rows at once rather than one at a time.
• Especially when deleting rows, turning screen updating off will speed the code and make it easier on the eyes.

** From your code it is unclear whether the 'blank' cells in column A are actually blank or contain a null string "", or perhaps some of each. The code below assumes they are blank but if that is not the case, we should be able to adapt the code if you are interested in this method.

Test with a copy of your data.

Sub Rearrange()
  Dim rBlank As Range, c As Range
 
  Set rBlank = Range("A1:A" & Range("B" & Rows.Count).End(xlUp).Row).SpecialCells(xlBlanks)
  Application.ScreenUpdating = False
  For Each c In rBlank
    c.Offset(-1, 7).Resize(, 5).Value = c.Offset(, 1).Resize(, 5).Value
  Next c
  rBlank.EntireRow.Delete
  Columns("K").NumberFormat = "mm/dd/yyyy"
  Application.ScreenUpdating = True
End Sub

@Peter_SSs @johnnyL

Thank you both so much for this and for the extend & comments! Much appreciated!

 

[Peter_SSs]

You're welcome. Glad we could help. Thanks for the follow-up.

 

[MB95]

You're welcome. Glad we could help. Thanks for the follow-up.

Hi Peter one last question, found something interesting in the initial range. I noticed in my large working file in "Column A" there are cells that appear to be blank but actually contain spaces (beyond annoying).

I was just wondering if there is a solution to alter the below section of the code (more specifically the ".SpecialCells(xlBlanks) to account for this.

Sub Rearrange()
  Dim rBlank As Range, c As Range
  Set rBlank = Range("A1:A" & Range("B" & Rows.Count).End(xlUp).Row).SpecialCells(xlBlanks)

My first thought would be to add a condition of If IsEmpty(currentRowValue) Or currentRowValue = "" Then but I am unsure how to go about it.

Thanks again!

 

[MB95]

Hi Peter one last question, found something interesting in the initial range. I noticed in my large working file in "Column A" there are cells that appear to be blank but actually contain spaces (beyond annoying).

View attachment 47993

I was just wondering if there is a solution to alter the below section of the code (more specifically the ".SpecialCells(xlBlanks) to account for this.

Sub Rearrange()
  Dim rBlank As Range, c As Range
  Set rBlank = Range("A1:A" & Range("B" & Rows.Count).End(xlUp).Row).SpecialCells(xlBlanks)

My first thought would be to add a condition of If IsEmpty(currentRowValue) Or currentRowValue = "" Then but I am unsure how to go about it.

Thanks again!

I think I may have figure it out with the below...

Sub Rearrange()
  Dim rBlank As Range, c As Range
  Set rBlank = Range("A1:A" & Range("B" & Rows.Count).End(xlUp).Row)
  Application.ScreenUpdating = False
  For Each c In rBlank
    If Trim(c) = vbNullString Or c = "" Then
        c.Offset(-1, 7).Resize(, 5).Value = c.Offset(, 1).Resize(, 5).Value
        c.Offset(-1, 7).Resize(, 5).Interior.ColorIndex = 36
    End If
    If Trim(c) = vbNullString Or c = "" Then
        c.EntireRow.Delete
    End If
  Next c
  Columns("K").NumberFormat = "mm/dd/yyyy"
  Application.ScreenUpdating = True
End Sub

 

[johnnyL]

Sub Rearrange()
'
    Dim rBlank As Range, c As Range, LastRow As Long
  '
    LastRow = Range("B" & Rows.Count).End(xlUp).Row
'
    Range("A1:A" & LastRow) = Application.Trim(Range("A1:A" & LastRow))
'
    Set rBlank = Range("A1:A" & LastRow).SpecialCells(xlBlanks)
'
    Application.ScreenUpdating = False
'
    For Each c In rBlank
        c.Offset(-1, 7).Resize(, 5).Value = c.Offset(, 1).Resize(, 5).Value
        c.Offset(-1, 7).Resize(, 5).Interior.ColorIndex = 36
    Next c
'
    rBlank.EntireRow.Delete
    Columns("K").NumberFormat = "mm/dd/yyyy"
'
    Application.ScreenUpdating = True
End Sub