VBA to copy strings according to predefined markers (numbers)

[smide]

Hello.

In Sheet2, Column B (B3:B50) I have a strings which I need to copy in Sheet1 , Row 3 in cells B3,D3,F3, ... V3 and X3 (12 in total).

In Sheet2, Column G is so called "markers" Column because it contains markers/numbers for each product and those markers define copy position for each cell (copy position in Sheet1, row3).

So, if let say (in Sheet2) cell G3=1 than string from cell B3 (Sheet2) should be copied in B3 (Sheet1) and so on...

- IF some cell(s) in G column (G3:G50) is empty (without marker) than delete appropriate string in column B.
- IF Column G is completely empty than JUST copy first 12 strings from Sheet2 (B3:B14) into Sheet1 (B3,D3,F3,...X3).
(B3 to B3, B4 to D3 ...)

Example.

Sheet2

	B	G
1
2
3	home	3
4	shop
5	mrexcel	1
6	pattern	6
7	question	2
8	product
9	best	5
10	forward	4
11	.....	....

<tbody>
</tbody>

Sheet1 (after macro run)

A

B

C

D

E

F

G

H

I

J

K

L

M

N

1

2

3

mrexcel

question

home

forward

best

pattern

...

<tbody>
</tbody>

Sheet2 (after macro run)

	B	G
1
2
3	home	3
4
5	mrexcel	1
6	pattern	6
7	question	2
8
9	best	5
10	forward	4
11	....

<tbody>
</tbody>

 

[oldbrewer]

In Sheet2, Column B (B3:B50) I have a strings which I need to copy in Sheet1 , Row 3 in cells B3,D3,F3, ... V3 and X3 (12 in total).

3

home

3

In Sheet2, Column G is so called "markers" Column because it contains markers/numbers for each product and those markers define copy position for each cell (copy position in Sheet1, row3).

4

5

mrexcel

1

So, if let say (in Sheet2) cell G3=1 than string from cell B3 (Sheet2) should be copied in B3 (Sheet1) and so on...

6

pattern

6

7

question

2

- IF some cell(s) in G column (G3:G50) is empty (without marker) than delete appropriate string in column B.

8

- IF Column G is completely empty than JUST copy first 12 strings from Sheet2 (B3:B14) into Sheet1 (B3,D3,F3,...X3).

9

best

5

(B3 to B3, B4 to D3 ...)

10

forward

4

this macro does it - I think…

For j = 3 To 10

If Cells(j, 3) = "" Then Cells(j, 2) = Cells(1, 1)

Next j

....

ccol = 2

num = 1

20 For k = 3 To 10

If Cells(k, 3) = num Then Cells(26, ccol) = Cells(k, 2): num = num + 1: ccol = ccol + 2: GoTo 20

Next k

End Sub

col B

D

F

H

J

L

mrexcel

question

home

forward

best

pattern

<colgroup><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col></colgroup><tbody>
</tbody>

 

[Rick Rothstein]

See if this code does what you want...

[table="******* 500"]
[tr]
	[td]Sub ProductMarkers()
  Dim UnusedColumn As Long, LastRow As Long, NewLastRow As Long
  UnusedColumn = Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column + 1
  LastRow = Cells(Rows.Count, "B").End(xlUp).Row
  Application.ScreenUpdating = False
  Cells(3, UnusedColumn).Resize(LastRow - 2) = Evaluate("ROW(3:" & LastRow & ")-2")
  Range("A3", Cells(LastRow, UnusedColumn)).Sort Range("G3"), xlAscending
  NewLastRow = Cells(Rows.Count, "G").End(xlUp).Row
  Sheets("Sheet1").Range("B3").Resize(, 2 * (NewLastRow - 2) - 1) = Split(Join(Application.Transpose(Range("B3").Resize(NewLastRow - 2)), Chr(1) & Chr(1)), Chr(1))
  Range("A3", Cells(LastRow, UnusedColumn)).Sort Cells(3, UnusedColumn), xlAscending
  Columns(UnusedColumn).Delete
  Application.ScreenUpdating = True
  Range("G3:G" & LastRow).SpecialCells(xlBlanks).EntireRow.Clear
End Sub[/td]
[/tr]
[/table]

 

[smide]

See if this code does what you want...

[TABLE]
<tbody>[TR]
[TD]Sub ProductMarkers()
  Dim UnusedColumn As Long, LastRow As Long, NewLastRow As Long
  UnusedColumn = Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column + 1
  LastRow = Cells(Rows.Count, "B").End(xlUp).Row
  Application.ScreenUpdating = False
  Cells(3, UnusedColumn).Resize(LastRow - 2) = Evaluate("ROW(3:" & LastRow & ")-2")
  Range("A3", Cells(LastRow, UnusedColumn)).Sort Range("G3"), xlAscending
  NewLastRow = Cells(Rows.Count, "G").End(xlUp).Row
  Sheets("Sheet1").Range("B3").Resize(, 2 * (NewLastRow - 2) - 1) = Split(Join(Application.Transpose(Range("B3").Resize(NewLastRow - 2)), Chr(1) & Chr(1)), Chr(1))
  Range("A3", Cells(LastRow, UnusedColumn)).Sort Cells(3, UnusedColumn), xlAscending
  Columns(UnusedColumn).Delete
  Application.ScreenUpdating = True
  Range("G3:G" & LastRow).SpecialCells(xlBlanks).EntireRow.Clear
End Sub[/TD]
[/TR]
</tbody>[/TABLE]

That's exactly what I wanted.
Thank you!