VBA SELECT THE FIRST CELLS THAT CONTAIN TEXT AND SHIFT THE VALUE BELOW IN THE RANGE

jhonatan321

New Member
Joined
Jul 14, 2021
Messages
10
Office Version
  1. 2016
Platform
  1. Windows
Can anyone help me with this code that I have problems doing for the last 2 days. What I need to do is find the last column in that particular row starting from column H onwards, if there is any text that shifts down the row in column G and repeat the action; when it finds the text in a cell it will then insert a row below it and cut and paste the text on the row below in column G. This continues until all cells from H onwards contain no text and proceeds to the next Row, repeating an action above.

my code does this but it got long and heavy because I had to create several ifs specifying which columns need to be shifted, because I have rows with more and others with less filled cells




in this example below, follow the reference: my column starts at H and the text of the cells onwards shift to column G blank cells will not be necessary to shift down.
1627563802862.png
1627563760737.png


Sub organizar_colunas_em_linhas()

' ESSE CODIGO IRA COLOCAR VARIAS COLUNAS NA MESMA LINHA
'Declarations
Dim wsData As Worksheet

Dim rngCopy As Range
Dim rngCopy1 As Range
Dim i As Long 'Loop variable
Dim j As Long 'Loop variable

Dim lngFirstDataRow As Long
Dim lngLastDataRow As Long

Dim boolDataFound As Boolean 'True or false value

'Initialization
Set wsData = ActiveSheet
lngFirstDataRow = 2 'Replace with your own value - row where the data starts
lngLastDataRow = 10760 'Replace with your own value - row where the data ends

'Loop from the bottom to top. Why? Because when we insert
'rows, it will shift stuff down.
For i = lngLastDataRow To lngFirstDataRow Step -1

'Check columns u - t for data
boolDataFound = False
For j = 1 To 1 'AL is the 38th column, AP the 42nd
'If it's not blank...
If Not wsData.Cells(i, j).Text = "" Then

'...then there is data. Change the boolean to TRUE and exit the for loop
boolDataFound = True
Exit For
End If
Next j

' I,X qual celula em qual coluna esta trazendo para baixo o dado
'If we found data there

If boolDataFound Then

'Insert a new row below the current row
wsData.Rows(i + 1).Insert Shift:=xlShiftDown

'Copy the data
Set rngCopy = wsData.Range(wsData.Cells(i, 9), wsData.Cells(i, 9))
rngCopy.Copy

'Copy that data into cells A-F
wsData.Cells(i + 1, 7).PasteSpecial xlPasteAll ' ordem inicial

End If
'''
'If we found data there
If boolDataFound Then

'Insert a new row below the current row
wsData.Rows(i + 1).Insert Shift:=xlShiftDown
'Copy the data
Set rngCopy = wsData.Range(wsData.Cells(i, 8), wsData.Cells(i, 8))
rngCopy.Copy

'Copy that data into cells A-F
wsData.Cells(i + 1, 7).PasteSpecial xlPasteAll ' ordem inicial

End If
'''
Next i

'Remove the copy mode
Application.CutCopyMode = False






End Sub
 

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.

Forum statistics

Threads
1,143,687
Messages
5,720,294
Members
422,275
Latest member
Maria95

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top