Macro Step to Find dash and copy cell values

[wazzulu1]

Hi;

I am trying to make a function to go through Column A, and when a "-" (dash, no quotes) is in the cell to then copy the next cell in column A to column B, but to then copy the same value to column C on the next row down, along with coping the value from that same row in column A to column D. This would need to loop through the column until it does not find another "-" (dash). Appreciate any suggestions for this. (Picture uploaded below)

 

[Fluff]

How about

Sub wazzulu()
   Dim Ar As Areas
   Dim Rng As Range
   
   With Range("A1", Range("A" & Rows.Count).End(xlUp))
      .Replace "-", "=xxx", xlWhole, , , , False, False
      Set Ar = .SpecialCells(xlConstants).Areas
      .Replace "=xxx", "-", xlWhole, , , , False, False
   End With
   For Each Rng In Ar
      Rng.Offset(, 1).Resize(1).Value = Rng.Value
      Rng.Offset(1, 2).Resize(Rng.Count - 1).Value = Rng.Resize(1).Value
      Rng.Offset(1, 3).Resize(Rng.Count - 1).Value = Rng.Offset(1).Resize(Rng.Count - 1).Value
   Next Rng
End Sub

 

[lrobbo314]

Whoa Fluff. That's totally different. Pretty cool. Here's another way.

TCO Transform (VBA).xlsb.xlsm
	A	B	C	D
1	-
2	aaa	aaa
3	bbb		aaa	bbb
4	ccc		aaa	ccc
5	ddd		aaa	ddd
6	eee		aaa	eee
7	-
8	mnb	mnb
9	jhg		mnb	jhg
10	lop		mnb	lop
11	ppp		mnb	ppp
12	htg		mnb	htg
13	-
14	yyy	yyy
15	bgt		yyy	bgt
16	pou		yyy	pou
17	wqe		yyy	wqe
Sheet2

Sub DASH()
Dim r As Range:         Set r = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
Dim AR() As Variant:    AR = r.Value2: ReDim Preserve AR(1 To UBound(AR), 1 To 4)
Dim LR As Long:         LR = UBound(AR)
Dim b As Boolean:       b = True

For i = UBound(AR) To 1 Step -1
    If AR(i, 1) = "-" Then
        For j = i + 1 To LR
            If b Then
                AR(j, 2) = AR(j, 1)
                b = False
            Else
                AR(j, 3) = AR(i + 1, 1)
                AR(j, 4) = AR(j, 1)
            End If
        Next j
        b = True
        LR = i - 1
    End If
Next i

r.Clear
Set r = r.Resize(UBound(AR), UBound(AR, 2))
r.Value2 = AR
End Sub

 

[lrobbo314]

Also, a way using Power Query.

TCO Transform (VBA).xlsb.xlsm
	A	B	C	D
1	Column1	ColB	ColC	ColD
2	-
3	aaa	aaa
4	bbb		aaa	bbb
5	ccc		aaa	ccc
6	ddd		aaa	ddd
7	eee		aaa	eee
8	-
9	mnb	mnb
10	jhg		mnb	jhg
11	lop		mnb	lop
12	ppp		mnb	ppp
13	htg		mnb	htg
14	-
15	yyy	yyy
16	bgt		yyy	bgt
17	pou		yyy	pou
18	wqe		yyy	wqe
Table3

let
    Source = Excel.CurrentWorkbook(){[Name="Table3"]}[Content],
    Index = Table.AddIndexColumn(Source, "Index", 0, 1, Int64.Type),
    ColB = Table.AddColumn(Index, "ColB", each try if Index[Column1]{[Index]-1} = "-" then [Column1] else null otherwise null),
    ColD = Table.AddColumn(ColB, "ColD", each if [Column1]<>"-" and [ColB]<>[Column1] then [Column1] else null),
    Duplicate = Table.FillDown(Table.DuplicateColumn(ColD, "ColB", "Duplicate"),{"Duplicate"}),
    ColC = Table.AddColumn(Duplicate, "ColC", each if [ColD] <> null then [Duplicate] else null),
    ROC = Table.SelectColumns(ColC,{"Column1", "ColB", "ColC", "ColD"})
in
    ROC

 

[wazzulu1]

Whoa Fluff. That's totally different. Pretty cool. Here's another way.

TCO Transform (VBA).xlsb.xlsm
	A	B	C	D
1	-
2	aaa	aaa
3	bbb		aaa	bbb
4	ccc		aaa	ccc
5	ddd		aaa	ddd
6	eee		aaa	eee
7	-
8	mnb	mnb
9	jhg		mnb	jhg
10	lop		mnb	lop
11	ppp		mnb	ppp
12	htg		mnb	htg
13	-
14	yyy	yyy
15	bgt		yyy	bgt
16	pou		yyy	pou
17	wqe		yyy	wqe
Sheet2

Sub DASH()
Dim r As Range:         Set r = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
Dim AR() As Variant:    AR = r.Value2: ReDim Preserve AR(1 To UBound(AR), 1 To 4)
Dim LR As Long:         LR = UBound(AR)
Dim b As Boolean:       b = True

For i = UBound(AR) To 1 Step -1
    If AR(i, 1) = "-" Then
        For j = i + 1 To LR
            If b Then
                AR(j, 2) = AR(j, 1)
                b = False
            Else
                AR(j, 3) = AR(i + 1, 1)
                AR(j, 4) = AR(j, 1)
            End If
        Next j
        b = True
        LR = i - 1
    End If
Next i

r.Clear
Set r = r.Resize(UBound(AR), UBound(AR, 2))
r.Value2 = AR
End Sub

hi, this did not work

 

[wazzulu1]

How about

Sub wazzulu()
   Dim Ar As Areas
   Dim Rng As Range
  
   With Range("A1", Range("A" & Rows.Count).End(xlUp))
      .Replace "-", "=xxx", xlWhole, , , , False, False
      Set Ar = .SpecialCells(xlConstants).Areas
      .Replace "=xxx", "-", xlWhole, , , , False, False
   End With
   For Each Rng In Ar
      Rng.Offset(, 1).Resize(1).Value = Rng.Value
      Rng.Offset(1, 2).Resize(Rng.Count - 1).Value = Rng.Resize(1).Value
      Rng.Offset(1, 3).Resize(Rng.Count - 1).Value = Rng.Offset(1).Resize(Rng.Count - 1).Value
   Next Rng
End Sub

I apologize, my example had the three characters, but in actuality, it's words/descriptions that are labels which exceed three alpha characters. This is copying the dash to column B, filling every cell in it with the dash, and did not copy like the example I showed.

 

[Fluff]

This is what I get after running my code.

+Fluff 1.xlsm
	A	B	C	D
1	-
2	aaa	aaa
3	bbb		aaa	bbb
4	ccc		aaa	ccc
5	ddd		aaa	ddd
6	eee		aaa	eee
7	-
8	mnb	mnb
9	fff		mnb	fff
10	ggg		mnb	ggg
11	hhh		mnb	hhh
12	iii		mnb	iii
13	jjj		mnb	jjj
14	-
15	yyy	yyy
16	bgt		yyy	bgt
17	pou		yyy	pou
18	wqe		yyy	wqe
19
Master

The length of text in the cells is irrelevant.
Please post an accurate sample of your data.

MrExcel has a tool called “XL2BB” that lets you post samples of your data that will allow us to copy/paste it to our Excel spreadsheets, so we can work with the same copy of data that you are. Instructions on using this tool can be found here: XL2BB Add-in

Note that there is also a "Test Here” forum on this board. This is a place where you can test using this tool (or any other posting techniques that you want to test) before trying to use those tools in your actual posts.