Sorting list of values by adjacent column text

[camerongreenfield]

Hi,

I am looking to create a vba macro button to sort through a single column range (in the example image it would be column "C") and copy corresponding adjacent cell values (Column "D") to another range area. The range area that the cell values are to be copied to is limited to 23 cells, once the 23 cells are fill the macro will need to continue copying the cells into the next specified range. These areas are grouped into pairs and named as different sheets. The macro will need to stop copying the adjacent cells onto the sheet when the text in column "C" changes. Ie S8 and S9 cannot be on the same sheet as one is a Wall and one is a truss in column "C".

 

[Ezguy4u]

Cameron, here is my solution. Now I have tried different scenarios to make sure that the program works correctly. One set-up that probably won’t work, if say Wallis has more than 46 items. As long as everybody has less than 46 items it will work. If you need any one sheet to accommodate more than 46 items, let us know. My solutions usually create more questions than answer so let the discussion begin. Sometimes the A plus students weigh in and gives us an even better program. Let’s see.

Sub CopyPaste1()

Dim col1 As Integer
Dim row1 As Integer
Dim row2 As Integer
Dim CellCnt As Integer

CellCnt = Cells(Rows.Count, "C").End(xlUp).Row

row1 = 4
row2 = 5
col1 = 7
Application.ScreenUpdating = False

Do Until IsEmpty(Cells(row1, 3))
Cells(row1, 4).Select
If Cells(row1, 3) = Cells(row1 + 1, 3) Then
        If col1 Mod 3 = 1 And row2 <= 27 Then
            Cells(row2, col1) = Cells(row1, 4)
            Cells(row2, col1).Select
            row2 = row2 + 1
        ElseIf col1 Mod 3 = 1 And row2 = 28 Then
            col1 = col1 + 1
            row2 = 5
            Cells(row2, col1) = Cells(row1, 4)
            Cells(row2, col1).Select
            row2 = row2 + 1
        ElseIf col1 Mod 3 = 2 Then
            Cells(row2, col1).Select
            Cells(row2, col1) = Cells(row1, 4)
            row2 = row2 + 1
        End If
Else
        If col1 Mod 3 = 1 And row2 <= 27 Then
            Cells(row2, col1).Select
            Cells(row2, col1) = Cells(row1, 4)
            col1 = col1 + 3
            row2 = 5
        ElseIf col1 Mod 3 = 1 And row2 >= 28 Then
            row2 = 5
            col1 = col1 + 1
            Cells(row2, col1) = Cells(row1, 4)
            Cells(row2, col1).Select
            col1 = col1 + 2
        ElseIf col1 Mod 3 = 2 Then
            Cells(row2, col1) = Cells(row1, 4)
            Cells(row2, col1).Select
            col1 = col1 + 2
            row2 = 5
        End If

End If
row1 = row1 + 1
Loop
Application.ScreenUpdating = True
End Sub

22-02-25 copy paste.xlsm
	C	D	E	F	G	H	I	J	K	L	M	N
4	WALLS	L1			SHEET 1			SHEET 2			SHEET 3
5	WALLS	L2			L1	S2		S4
6	WALLS	L3			L2	S3		S5
7	WALLS	L4			L3			S6
8	WALLS	L5			L4			S7
9	WALLS	L6			L5			S8
10	WALLS	L7			L6			S9
11	WALLS	L8			L7			S10
12	WALLS	L9			L8			S11
13	WALLS	L10			L9			S12
14	WALLS	L11			L10			S13
15	WALLS	L12			L11			S14
16	WALLS	L13			L12			S15
17	WALLS	L14			L13			S16
18	WALLS	L15			L14			S17
19	WALLS	L16			L15			S18
20	WALLS	L17			L16			S19
21	WALLS	N1			L17
22	WALLS	N2			N1
23	WALLS	N3			N2
24	WALLS	N4			N3
25	WALLS	N5			N4
26	WALLS	S1			N5
27	WALLS	S2			S1
28	WALLS	S3
29	TRUSS	S4
30	TRUSS	S5
31	TRUSS	S6
32	TRUSS	S7
33	TRUSS	S8
34	TRUSS	S9
35	TRUSS	S10
36	TRUSS	S11
37	TRUSS	S12
38	TRUSS	S13
39	TRUSS	S14
40	TRUSS	S15
41	TRUSS	S16
42	TRUSS	S17
43	TRUSS	S18
44	TRUSS	S19
Copy Pate

 

[camerongreenfield]

Hi Ezguy4u,
Yes that's very close to what I am looking for. However, there may be cases where the category "Walls" for example may be over 46 items and will then need to continue onto the next sheet. If we could have the program do that as well then it would be exactly what I am after. Thanks

 

[Ezguy4u]

Cameron, it turns out that I just had to add a couple more lines of code and it now accommodates more than 46 items. Be sure to let us know if there are any problems.

Sub CopyPaste1revA()

Dim col1 As Integer
Dim row1 As Integer
Dim row2 As Integer
Dim CellCnt As Integer

CellCnt = Cells(Rows.Count, "C").End(xlUp).Row

row1 = 4
row2 = 5
col1 = 7
Application.ScreenUpdating = False

Do Until IsEmpty(Cells(row1, 3))
Cells(row1, 4).Select
If Cells(row1, 3) = Cells(row1 + 1, 3) Then
        If col1 Mod 3 = 1 And row2 <= 27 Then
            Cells(row2, col1) = Cells(row1, 4)
            Cells(row2, col1).Select
            row2 = row2 + 1
        ElseIf col1 Mod 3 = 1 And row2 = 28 Then
            col1 = col1 + 1
            row2 = 5
            Cells(row2, col1) = Cells(row1, 4)
            Cells(row2, col1).Select
            row2 = row2 + 1
        ElseIf col1 Mod 3 = 2 And row2 <= 27 Then
            Cells(row2, col1).Select
            Cells(row2, col1) = Cells(row1, 4)
            row2 = row2 + 1
         ElseIf col1 Mod 3 = 2 And row2 = 28 Then
            col1 = col1 + 2
            row2 = 5
            Cells(row2, col1).Select
            Cells(row2, col1) = Cells(row1, 4)
            row2 = row2 + 1
        End If
Else
        If col1 Mod 3 = 1 And row2 <= 27 Then
            Cells(row2, col1).Select
            Cells(row2, col1) = Cells(row1, 4)
            col1 = col1 + 3
            row2 = 5
        ElseIf col1 Mod 3 = 1 And row2 >= 28 Then
            row2 = 5
            col1 = col1 + 1
            Cells(row2, col1) = Cells(row1, 4)
            Cells(row2, col1).Select
            col1 = col1 + 2
        ElseIf col1 Mod 3 = 2 Then
            Cells(row2, col1) = Cells(row1, 4)
            Cells(row2, col1).Select
            col1 = col1 + 2
            row2 = 5
        End If

End If
row1 = row1 + 1
Loop
Application.ScreenUpdating = True
End Sub