VBA Shifts multiple data cells down and inserts rows below

jhonatan321

New Member
Joined
Jul 14, 2021
Messages
10
Office Version
  1. 2016
Platform
  1. Windows
Good morning team, I have a code in vba that shifts the lines from column 8 to the line below it is working perfectly but I have lines that have 10 cells with values and others that only have 1 I made a code too long pulling 50 cells and putting them below and my problem is that a lot of blank cells are coming, I would like to bring only cells with values, I will share the code I am using, the idea is to shift all cells with values in the specified range without bringing blank cells, the code below will shift the cell in column 8 and 9. below column 7Bom dia time, tenho um codigo em vba que desloca as linhas apartir da coluna 8 para linha abaixo esta funcionando perfeitamente porem tenho linhas que tem 10 celulas com valores e outras que só tem 1 eu fiz um codigo extenso demais puxando 50 celulas e colocando abaixo e meu problema é que esta vindo muita celula em branco gostaria de trazer apenas celulas com valores, vou compartilhar o codigo que estou usando, a ideia é deslocar todas as celulas com valores no intervalo especificado sem trazer celulas em branco, o codigo abaixo vai deslocar a celula na coluna 8 e 9. abaixo da coluna 7



Sub organizar_colunas_em_linhas()


'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


Pasta1
ABCDEFGHIJ
1teste 1teste 2teste 3teste 4teste 5teste 6teste 7teste 8teste 9teste 10
2aa 1aa 2aa 3aa 4aa 5aa 6aa 7aa 8aa 9aa 10
data
 

Excel Facts

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)

Forum statistics

Threads
1,213,487
Messages
6,113,938
Members
448,534
Latest member
benefuexx

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
Back
Top