Move descriptions

Panoos64 · Oct 12, 2018

Hi all, I would like to write a VBA code so that, to run through col. “F” and rows down and where exist bold descriptions should move them to adjacent cells in col. “A”

Therefore, that the code should start from “F11”. Below I present the original data and the expected result. Thanking you in advance

ORIGINAL DATA

	A	B	C	D	E	F	G	H	J
9	Date	TYPE	CODE	DEPARTMENT/REF.	ENTRY #	DEPARTMENT		DESCRIPTION	AMOUNT
10
11	17-07-16	RUR	202060	RESTAURANT 120125	120125	RESTAURANT		LEMONADE SQUASH	120.25
12	22-07-16	ISS	202075	RESTAURANT 121255	121255	RESTAURANT		REFRESHMENTS	250.48
13						RESTAURANT TOTAL			370.73
14
15	12-06-18	PUR	202088	POOL BAR 121230	121230	POOL BAR		ORANGE SQUASH	108.95
16	17-06-18	ISS	202095	POOL BAR 121345	121345	POOL BAR		GRENADINE SYRUP	95.45
17	13-07-18	PUR	202009	POOL BAR 122478	122478	POOL BAR		ICE TEA	150.45
18						POOL BAR TOTAL			354.85

EXPECTED RESULT

	A	B	C	D	E	F	G	H	J
9	Date	TYPE	CODE	DEPARTMENT/REF.	ENTRY #	DEPARTMENT		DESCRIPTION	AMOUNT
10
11	17-07-16	RUR	202060	RESTAURANT 120125	120125	RESTAURANT		LEMONADE SQUASH	120.25
12	22-07-16	ISS	202075	RESTAURANT 121255	121255	RESTAURANT		REFRESHMENTS	250.48
13	RESTAURANT TOTAL								370.73
14
15	12-06-18	PUR	202088	POOL BAR 121230	121230	POOL BAR		ORANGE SQUASH	108.95
16	17-06-18	ISS	202095	POOL BAR 121345	121345	POOL BAR		GRENADINE SYRUP	95.45
17	13-07-18	PUR	202009	POOL BAR 122478	122478	POOL BAR		ICE TEA	150.45
18	POOL BAR TOTAL								354.85

Trebor76 · Oct 12, 2018

Hi Panoos64,

Try this while on the sheet with the data:

Code:

Option Explicit
Sub Macro1()

    Dim lngLastRow As Long
    Dim lngMyRow   As Long
    
    Application.ScreenUpdating = False
    
    lngLastRow = Range("A:F").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    For lngMyRow = 11 To lngLastRow
        If Range("F" & lngMyRow).Font.Bold = True Then
            With Range("A" & lngMyRow)
                .Value = Range("F" & lngMyRow).Value
                .Font.Bold = True
            End With
            Range("F" & lngMyRow).ClearContents
        End If
    Next lngMyRow
    
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

Fluff · Oct 12, 2018

Another option

Code:

Sub MoveTotal()
Dim rng As Range

   For Each rng In Range("A9", Range("F" & Rows.Count).End(xlUp).Offset(, -5)).SpecialCells(xlBlanks).Areas
      rng.Value = rng.Offset(, 5).Value
      rng.Font.Bold = True
      rng.Offset(, 5).ClearContents
   Next rng
End Sub

Panoos64 · Oct 12, 2018

Hi Trebor, thank you so much, the code works perfect and nicely. Thanks once again for your support and your time spent for my project. Hv a great day!

Panoos64 · Oct 12, 2018

Thank you Fluf, your code works and is according to my data. Thanks also for your continuance support. Hv a lovely day!

Fluff · Oct 13, 2018

Glad we could help & thanks for the feedback

Move descriptions

Panoos64

Well-known Member

Excel Facts

Trebor76

Well-known Member

Fluff

MrExcel MVP, Moderator

Panoos64

Well-known Member

Panoos64

Well-known Member

Fluff

MrExcel MVP, Moderator

Similar threads

Forum statistics

Share this page

Move descriptions

Panoos64

Well-known Member

Excel Facts

Trebor76

Well-known Member

Fluff

MrExcel MVP, Moderator

Panoos64

Well-known Member

Panoos64

Well-known Member

Fluff

MrExcel MVP, Moderator

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock