How to arrange cells like this?

**robertdino** · 07-28-2017, 06:11 PM

I have a bank statement with some entries like this.
As you can see, the description is split vertically into 2 cells in 2 different rows and the amounts/credit or debit come in the lower row as well.

I need a macro that will detect all cells with missing dates in column A, then shift all data in that correspondent row to the row above and then delete the blank row when the data is shifted up so each transaction in the sheet comes in 1 row with all details in the same row.

Help

**Kenneth Hobson** · 07-28-2017, 08:42 PM

**robertdino** · 07-28-2017, 10:44 PM

Originally Posted by Kenneth Hobson

Welcome to the forum!

What happens to the cells with data already in them like B1 and B2? Delete B2, or combine B1 and B2 delimited by a space character, or...

Data in B2 should be combined with data in B1 with no space in between.
Then row 2 should be removed and lower row takes its place.

**Kenneth Hobson** · 07-29-2017, 12:41 AM

Place code in a Module. Run for active sheet. Be sure to run on a backup copy as usual when testing copy.

Code:

Sub MoveRowsUp()
  Dim r As Range, r1 As Range, r2 As Range, v, i As Long
  
  Set r = Range("A1", Range("A1").End(xlDown).Offset(1))
  
  Application.EnableEvents = False
  Application.DisplayAlerts = False
  Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False
  
  On Error GoTo EndSub
  For i = r.Rows.Count To 1 Step -1
    Set r1 = Cells(i, "A")
    Set r2 = Cells(i - 1, "A")
    If r1.Value = "" And r2.Value > 0 Then
      'Concatenate column B values
      v = r2.Offset(, 1).Value & r1.Offset(, 1).Value
      Range("B" & i & ":F" & i).Cut Destination:=Range("B" & i - 1 & ":F" & i)
      Rows(i).Delete Shift:=xlUp
      Cells(i - 1, "B").Value = v 'Add concatenated column B value back.
    End If
  Next i
  
EndSub:
  Application.EnableEvents = True
  Application.DisplayAlerts = True
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
End Sub

**robertdino** · 07-29-2017, 11:57 AM

Originally Posted by Kenneth Hobson

Place code in a Module. Run for active sheet. Be sure to run on a backup copy as usual when testing copy.

Code:

Sub MoveRowsUp()
  Dim r As Range, r1 As Range, r2 As Range, v, i As Long
  
  Set r = Range("A1", Range("A1").End(xlDown).Offset(1))
  
  Application.EnableEvents = False
  Application.DisplayAlerts = False
  Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False
  
  On Error GoTo EndSub
  For i = r.Rows.Count To 1 Step -1
    Set r1 = Cells(i, "A")
    Set r2 = Cells(i - 1, "A")
    If r1.Value = "" And r2.Value > 0 Then
      'Concatenate column B values
      v = r2.Offset(, 1).Value & r1.Offset(, 1).Value
      Range("B" & i & ":F" & i).Cut Destination:=Range("B" & i - 1 & ":F" & i)
      Rows(i).Delete Shift:=xlUp
      Cells(i - 1, "B").Value = v 'Add concatenated column B value back.
    End If
  Next i
  
EndSub:
  Application.EnableEvents = True
  Application.DisplayAlerts = True
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
End Sub

Works but only once for 1 row. Should do the whole sheet in a single go.
Also the column F becomes blank (Cr/Dr goes away)

**Admin** · 07-29-2017, 01:09 PM

replace

Code:

Set r = Range("A1", Range("A1").End(xlDown).Offset(1))

with

Code:

Set r = Range("A1", Range("A" & Rows.Count).End(xlUp).Offset(1))

**erpurohit** · 07-31-2017, 09:37 PM

If you are looking for solution without code than this might help

Sample.xlsx

**Kenneth Hobson** · 09-01-2017, 07:48 PM

Change that one line as Admin showed or this way. I did not catch that as I only tested using your example.

I did not see a problem with column F. I did not see a Dr in your example.

Attaching a short example file is one of the better ways to help us help you.

Code:

Sub MoveRowsUp()
  Dim r As Range, r1 As Range, r2 As Range, v, i As Long
  
  Set r = Range("A1", Cells(Rows.Count, "A").End(xlUp).Offset(1))
  
  Application.EnableEvents = False
  Application.DisplayAlerts = False
  Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False
  
  On Error GoTo EndSub
  For i = r.Rows.Count To 1 Step -1
    Set r1 = Cells(i, "A")
    Set r2 = Cells(i - 1, "A")
    If r1.Value = "" And r2.Value > 0 Then
      'Concatenate column B values
      v = r2.Offset(, 1).Value & r1.Offset(, 1).Value
      Range("B" & i & ":F" & i).Cut Destination:=Range("B" & i - 1 & ":F" & i)
      Rows(i).Delete Shift:=xlUp
      Cells(i - 1, "B").Value = v 'Add concatenated column B value back.
    End If
  Next i
  
EndSub:
  Application.EnableEvents = True
  Application.DisplayAlerts = True
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
End Sub

**snb** · 09-04-2017, 10:52 AM

or

Code:

Sub M_snb()
  sn=cells(1).currentregion

  for j=2 to ubound(sn)
    sn(j,1)=sn(j-1,1)
    sn((j,2)=sn(j-1,2) & " " & sn(j,2)
    sn((j-1,1)=""
    sn(j-1,2)=""
  next

  with sheets.add
    .cells(1).resize(j,ubound(sn,2))=sn
    .columns(1).specialcells(4).entirerow.delete
  end with
End Sub