Concatenate (join cell values) based on other cell values

paneliyadhruv · Jul 10, 2018

Dear all experts,

I need help to move the range of input and output.
In column B start No and column C end number. Based on first macro i am able to generate serial number with common prefix from columns K to AI.

Similarly, column D start No and column E end number. Based on second macro i am able to generate serial number with common prefix from columns AL to BJ.

Now as per my requirement is to concatenate (join) the same column value based on values present in column G and H for serial No. 1 and 2, respectively.

Macro 3 used to concatenate (join) the cell value based on value present on G4 of column K and output in column - BM (need help to move range down and output from columns BN to CK based on value in column G5 to end).
Macro 4 used to concatenate (join) the cell value based on value present on H4 of column AL and output in column CN (need help to move range down and output from columns CO to DL based on value in column H5 to end).

If number generation and concatenate work together then no need to generate series.

Please find worksheet with highlighted color for each sequence of input and output.

Thank you very much in advance.

Code:

Sub No_serial_1()With Worksheets("Sheet1")
    .Activate
Dim rng As Range, d As Range, cel As Range
Dim addStr As String
Set rng = Sheet1.Range([B4], Cells(Rows.Count, "B").End(xlUp))
addStr = Sheet1.Range("A4:A4")
Set d = [j1]
For Each cel In rng
    Set d = d(1, 2)
    d = cel
    d.AutoFill d.Resize(cel(1, 2) - cel + 1), xlFillSeries
    d.Resize(cel(1, 2)).NumberFormat = addStr & 0
Next
End With
End Sub


Sub No_serial_2()
With Worksheets("Sheet1")
    .Activate
Dim rng As Range, d As Range, cel As Range
Dim addStr As String
Set rng = Sheet1.Range([D4], Cells(Rows.Count, "D").End(xlUp))
addStr = Sheet1.Range("A4:A4")
Set d = [AK1]
For Each cel In rng
    Set d = d(1, 2)
    d = cel
    d.AutoFill d.Resize(cel(1, 2) - cel + 1), xlFillSeries
    d.Resize(cel(1, 2)).NumberFormat = addStr & 0
Next
End With
End Sub
Sub Concatenate_No_serial_1()
'for concatenate serail No 1
On Error Resume Next


With Sheet1
    .Activate


Dim r As Long, lr As Long, nr As Long, qr As Long
Dim L&


L = Sheet1.Range("G4")
If L = 2 Then


lr = Sheet1.Cells(Rows.Count, 11).End(xlUp).Row 'lr = Sheet2.Cells(Rows.Count, change column input).End(xlUp).Row
For r = 1 To lr Step L
  nr = nr + 1
  Sheet1.Cells(nr, 65) = Cells(r, 11).Text & ", " & Cells(r + 1, 11).Text 'Sheet3.Cells(nr, change column output) =Cells(r, change column input) & ", " & Cells(r + 1, change column input)
  If Right(Sheet1.Cells(nr, 2), 1) = "," Then
    Sheet1.Cells(nr, 2) = Left(Cells(nr, 2), Len(Cells(nr, 2)) - 1)
  End If
Next r
Else
If L = 3 Then


lr = Sheet1.Cells(Rows.Count, 11).End(xlUp).Row 'lr = Sheet2.Cells(Rows.Count, change column input).End(xlUp).Row
For r = 1 To lr Step L
  nr = nr + 1
  Sheet1.Cells(nr, 65) = Cells(r, 11).Text & ", " & Cells(r + 1, 11).Text & ", " & Cells(r + 2, 11).Text   'Sheet3.Cells(nr, change column output) =Cells(r, change column input) & ", " & Cells(r + 1, change column input)
  If Right(Sheet1.Cells(nr, 2), 1) = "," Then
    Sheet1.Cells(nr, 2) = Left(Cells(nr, 2), Len(Cells(nr, 2)) - 1)
  End If
Next r
Else


If L = 4 Then


lr = Sheet1.Cells(Rows.Count, 11).End(xlUp).Row 'lr = Sheet2.Cells(Rows.Count, change column input).End(xlUp).Row
For r = 1 To lr Step L
  nr = nr + 1
  Sheet1.Cells(nr, 65) = Cells(r, 11).Text & ", " & Cells(r + 1, 11).Text & ", " & Cells(r + 2, 11).Text & ", " & Cells(r + 3, 11).Text  'Sheet3.Cells(nr, change column output) =Cells(r, change column input) & ", " & Cells(r + 1, change column input)
  If Right(Sheet1.Cells(nr, 2), 1) = "," Then
    Sheet1.Cells(nr, 2) = Left(Cells(nr, 2), Len(Cells(nr, 2)) - 1)
  End If
Next r
Else


If L = 5 Then


lr = Sheet1.Cells(Rows.Count, 11).End(xlUp).Row 'lr = Sheet2.Cells(Rows.Count, change column input).End(xlUp).Row
For r = 1 To lr Step L
  nr = nr + 1
  Sheet1.Cells(nr, 65) = Cells(r, 11).Text & ", " & Cells(r + 1, 11).Text & ", " & Cells(r + 2, 11).Text & ", " & Cells(r + 3, 11).Text & ", " & Cells(r + 4, 11).Text 'Sheet3.Cells(nr, change column output) =Cells(r, change column input) & ", " & Cells(r + 1, change column input)
  If Right(Sheet1.Cells(nr, 2), 1) = "," Then
    Sheet1.Cells(nr, 2) = Left(Cells(nr, 2), Len(Cells(nr, 2)) - 1)
  End If
Next r
Else


lr = Sheet1.Cells(Rows.Count, 11).End(xlUp).Row 'lr = Sheet2.Cells(Rows.Count, change column input).End(xlUp).Row
For r = 1 To lr Step 1
  nr = nr + 1
  Sheet1.Cells(nr, 65) = Cells(r, 11).Text '& ", " & Cells(r + 1, 65) & ", " & Cells(r + 2, 65) 'Sheet3.Cells(nr, change column output) =Cells(r, change column input) & ", " & Cells(r + 1, change column input)
  If Right(Sheet1.Cells(nr, 2), 1) = "," Then
    Sheet1.Cells(nr, 2) = Left(Cells(nr, 2), Len(Cells(nr, 2)) - 1)
  End If
Next r
Sheet3.Columns(65).AutoFit


End If
End If
End If
End If
End With
End Sub


Sub Concatenate_No_serial_2()
'for concatenate serail No 2
On Error Resume Next


With Sheet1
    .Activate


Dim r As Long, lr As Long, nr As Long, qr As Long
Dim L&


L = Sheet1.Range("H4")
If L = 2 Then


lr = Sheet1.Cells(Rows.Count, 38).End(xlUp).Row 'lr = Sheet2.Cells(Rows.Count, change column input).End(xlUp).Row
For r = 1 To lr Step L
  nr = nr + 1
  Sheet1.Cells(nr, 92) = Cells(r, 38).Text & ", " & Cells(r + 1, 38).Text 'Sheet3.Cells(nr, change column output) =Cells(r, change column input) & ", " & Cells(r + 1, change column input)
  If Right(Sheet1.Cells(nr, 2), 1) = "," Then
    Sheet1.Cells(nr, 2) = Left(Cells(nr, 2), Len(Cells(nr, 2)) - 1)
  End If
Next r
Else
If L = 3 Then


lr = Sheet1.Cells(Rows.Count, 38).End(xlUp).Row 'lr = Sheet2.Cells(Rows.Count, change column input).End(xlUp).Row
For r = 1 To lr Step L
  nr = nr + 1
  Sheet1.Cells(nr, 92) = Cells(r, 38).Text & ", " & Cells(r + 1, 38).Text & ", " & Cells(r + 2, 38).Text   'Sheet3.Cells(nr, change column output) =Cells(r, change column input) & ", " & Cells(r + 1, change column input)
  If Right(Sheet1.Cells(nr, 2), 1) = "," Then
    Sheet1.Cells(nr, 2) = Left(Cells(nr, 2), Len(Cells(nr, 2)) - 1)
  End If
Next r
Else


If L = 4 Then


lr = Sheet1.Cells(Rows.Count, 38).End(xlUp).Row 'lr = Sheet2.Cells(Rows.Count, change column input).End(xlUp).Row
For r = 1 To lr Step L
  nr = nr + 1
  Sheet1.Cells(nr, 92) = Cells(r, 38).Text & ", " & Cells(r + 1, 38).Text & ", " & Cells(r + 2, 38).Text & ", " & Cells(r + 3, 38).Text  'Sheet3.Cells(nr, change column output) =Cells(r, change column input) & ", " & Cells(r + 1, change column input)
  If Right(Sheet1.Cells(nr, 2), 1) = "," Then
    Sheet1.Cells(nr, 2) = Left(Cells(nr, 2), Len(Cells(nr, 2)) - 1)
  End If
Next r
Else


If L = 5 Then


lr = Sheet1.Cells(Rows.Count, 38).End(xlUp).Row 'lr = Sheet2.Cells(Rows.Count, change column input).End(xlUp).Row
For r = 1 To lr Step L
  nr = nr + 1
  Sheet1.Cells(nr, 92) = Cells(r, 38).Text & ", " & Cells(r + 1, 38).Text & ", " & Cells(r + 2, 38).Text & ", " & Cells(r + 3, 38).Text & ", " & Cells(r + 4, 38).Text 'Sheet3.Cells(nr, change column output) =Cells(r, change column input) & ", " & Cells(r + 1, change column input)
  If Right(Sheet1.Cells(nr, 2), 1) = "," Then
    Sheet1.Cells(nr, 2) = Left(Cells(nr, 2), Len(Cells(nr, 2)) - 1)
  End If
Next r
Else


lr = Sheet1.Cells(Rows.Count, 38).End(xlUp).Row 'lr = Sheet2.Cells(Rows.Count, change column input).End(xlUp).Row
For r = 1 To lr Step 1
  nr = nr + 1
  Sheet1.Cells(nr, 92) = Cells(r, 38).Text '& ", " & Cells(r + 1, 65) & ", " & Cells(r + 2, 65) 'Sheet3.Cells(nr, change column output) =Cells(r, change column input) & ", " & Cells(r + 1, change column input)
  If Right(Sheet1.Cells(nr, 2), 1) = "," Then
    Sheet1.Cells(nr, 2) = Left(Cells(nr, 2), Len(Cells(nr, 2)) - 1)
  End If
Next r
Sheet3.Columns(92).AutoFit


End If
End If
End If
End If
End With
End Sub

paneliyadhruv · Jul 12, 2018

Dear Sir,

Either horizontal or vertical data is suitable for me. Output in next available column separately for each range (start and end no).
Use either data as per your feasibility. Even I can move row or column as per your suggestion.

Thank you for your valuable time and help.

Peter_SSs · Jul 12, 2018

Using the first two screen shots in post 10, try this.

Code:

Sub Concat_Items_v2()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, strt As Long, stp As Long, grp As Long, lr As Long, r As Long
  Dim pref As String, s As String
  
  With Range("A4", Range("G" & Rows.Count).End(xlUp))
    a = Application.Index(.Value, Evaluate("Row(1:" & .Rows.Count & ")"), Array(1, 2, 3, 7))
  End With
  ReDim b(1 To Rows.Count, 1 To UBound(a))
  For i = 1 To UBound(a)
    pref = a(i, 1)
    strt = a(i, 2)
    stp = a(i, 3)
    grp = a(i, 4)
    s = vbNullString
    r = 0
    For j = strt To stp
      s = s & ", " & pref & j
      If (j - strt + 1) Mod grp = 0 Or j = stp Then
        r = r + 1
        b(r, i) = Mid(s, 3)
        s = vbNullString
      End If
    Next j
    If r > lr Then lr = r
  Next i
  Application.ScreenUpdating = False
  With Range("K4").Resize(lr, UBound(b, 2))
    .Value = b
    .Columns.AutoFit
  End With
  Application.ScreenUpdating = True
End Sub

Book1

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

3

Prefix

Start No

End No

Num

4

AA

101

110

1

AA101

BC111, BC112, BC113

D121, D122

E131, E132

F141, F142, F143, F144

G151, G152, G153, G154

H161, H162

5

BC

111

120

3

AA102

BC114, BC115, BC116

D123, D124

E133, E134

F145, F146, F147, F148

G155, G156, G157, G158

H163, H164

6

D

121

130

2

AA103

BC117, BC118, BC119

D125, D126

E135, E136

F149, F150

G159, G160

H165, H166

7

E

131

140

2

AA104

BC120

D127, D128

E137, E138

H167, H168

8

F

141

150

4

AA105

D129, D130

E139, E140

H169, H170

9

G

151

160

4

AA106

10

H

161

170

2

AA107

11

I

171

180

3

AA108

12

J

181

190

4

AA109

13

K

191

200

1

AA110

14

L

201

210

2

15

M

211

220

3

16

N

221

230

1

17

O

231

240

2

18

P

241

250

3

19

Q

251

260

2

20

R

261

270

2

21

S

271

280

2

22

T

281

290

2

23

U

291

300

2

24

V

301

310

2

25

W

311

320

2

26

X

321

330

2

27

Y

331

340

2

28

Z

341

350

2

Sheet2

paneliyadhruv · Jul 12, 2018

Dear Sir,

Working perfectly.
Thank you very much Sir for your kind help.
Have a good day.

Peter_SSs · Jul 13, 2018

paneliyadhruv said:
Dear Sir,

Working perfectly.
Thank you very much Sir for your kind help.
Have a good day.

You're welcome. A lot easier once I could see the layout required.

Rick Rothstein · Jul 13, 2018

Peter_SSs said:

Using the first two screen shots in post 10, try this.

Rich (BB code):

Sub Concat_Items_v2()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, strt As Long, stp As Long, grp As Long, lr As Long, r As Long
  Dim pref As String, s As String
  
  With Range("A4", Range("G" & Rows.Count).End(xlUp))
    a = Application.Index(.Value, Evaluate("Row(1:" & .Rows.Count & ")"), Array(1, 2, 3, 7))
  End With
  ReDim b(1 To Rows.Count, 1 To UBound(a))
  For i = 1 To UBound(a)
    pref = a(i, 1)
    strt = a(i, 2)
    stp = a(i, 3)
    grp = a(i, 4)
    s = vbNullString
    r = 0
    For j = strt To stp
      s = s & ", " & pref & j
      If (j - strt + 1) Mod grp = 0 Or j = stp Then
        r = r + 1
        b(r, i) = Mid(s, 3)
        s = vbNullString
      End If
    Next j
    If r > lr Then lr = r
  Next i
  Application.ScreenUpdating = False
  With Range("K4").Resize(lr, UBound(b, 2))
    .Value = b
    .Columns.AutoFit
  End With
  Application.ScreenUpdating = True
End Sub

I am not completely sure why, but when I run your code, I get a "Run-time error '7': Out of memory" on this line of code...

.Value = b

I think it may be because your 'b' array is dimensioned to 1,048,576 rows deep by, for your posted example, 25 columns wide. The following code which I wrote for the layout you showed runs without problem... probably because I limit the depth of the Result array (the equivalent to your 'b' array) to exactly what is needed to hold the total output. I'm guessing if you used the same technique to limit your 'b' array, then your code would run on my system without problem.

Code:

[table="width: 500"]
[tr]
	[td]Sub PrefixedRanges()
  Dim r As Long, ResR As Long, ResC As Long, Inc As Long, Cnt As Long, LastRow As Long
  Dim Data As Variant, Result As Variant
  LastRow = Cells(Rows.Count, "A").End(xlUp).Row
  Data = Range("A4:G" & LastRow)
  ReDim Result([B][COLOR="#0000FF"]1 To Evaluate(Replace("1+MAX((C4:C#-B4:B#)/G4:G#)", "#", LastRow))[/COLOR][/B], 1 To UBound(Data))
  For r = 1 To UBound(Data)
    ResR = 0
    ResC = ResC + 1
    For Inc = Data(r, 2) To Data(r, 3) Step Data(r, 7)
      ResR = ResR + 1
      For Cnt = 0 To Data(r, 7) - 1
        If Inc + Cnt - 1 < Data(r, 3) Then Result(ResR, ResC) = Result(ResR, ResC) & ", " & Data(r, 1) & Inc + Cnt
      Next
      Result(ResR, ResC) = Mid(Result(ResR, ResC), 3)
    Next
  Next
  Application.ScreenUpdating = False
  With Intersect(Columns("K").Resize(, Columns.Count - 11), ActiveSheet.UsedRange)
    .Cells.Clear
    Range("K4").Resize(UBound(Result, 1), UBound(Result, 2)) = Result
    .EntireColumn.AutoFit
  End With
  Application.ScreenUpdating = True
End Sub[/td]
[/tr]
[/table]

Peter_SSs · Jul 13, 2018

Rick Rothstein said:
I am not completely sure why, but when I run your code, I get a "Run-time error '7': Out of memory" on this line of code...

.Value = b

I think it may be because your 'b' array is dimensioned to 1,048,576 rows deep

I don't think that should be the problem since my code restricts the output to 'lr' rows of the 'b' array. I wonder what the value of lr is when the error occurs for you?

In any case the code as posted worked fine for the samples I tested with and obviously for the OP so far, judging by the response in post 13.

Rick Rothstein · Jul 13, 2018

Peter_SSs said:
I don't think that should be the problem since my code restricts the output to 'lr' rows of the 'b' array. I wonder what the value of lr is when the error occurs for you?

The value of 'lr' when the error occurs is 10 (the loop it is in runs completely). I decided to try using the method I used to ReDim the 'b' array...

Code:

ReDim b(1 To Evaluate(Replace("1+MAX((C4:C#-B4:B#)/G4:G#)", "#", Cells(Rows.Count, "A").End(xlUp).Row)), 1 To UBound(a))

and when I do that, your code runs fine, so I do think it is somehow related to the size the 'b' array is ReDim'med to.

Rick Rothstein · Jul 13, 2018

Rick Rothstein said:
The value of 'lr' when the error occurs is 10 (the loop it is in runs completely). I decided to try using the method I used to ReDim the 'b' array...

Code:

ReDim b(1 To Evaluate(Replace("1+MAX((C4:C#-B4:B#)/G4:G#)", "#", Cells(Rows.Count, "A").End(xlUp).Row)), 1 To UBound(a))

and when I do that, your code runs fine, so I do think it is somehow related to the size the 'b' array is ReDim'med to.

I wonder if maybe it is a version problem... I am using Excel 2010. The line of code it is dying on is this one...

Code:

.Value = b

That .Value refers back to a range that starts on Row 4 and you are trying to assign an array with 1,048,576 rows in it (which is the total number of rows on a worksheet) to it. I know you are restricting the range that will accept values, but still you are telling VB to assign an array with the same number of rows as there are rows on a worksheet to a cell starting 4 rows down which may mean VB thinks the array falls off the bottom of the worksheet before it realizes that that many rows will not actually be assigned. Maybe that is a problem with Excel 2010 (and possibly earlier versions) that was fixed (accounted for) in later versions.

Concatenate (join cell values) based on other cell values

paneliyadhruv

New Member

paneliyadhruv

New Member

Excel Facts

Peter_SSs

MrExcel MVP, Moderator

paneliyadhruv

New Member

Peter_SSs

MrExcel MVP, Moderator

Rick Rothstein

MrExcel MVP

Peter_SSs

MrExcel MVP, Moderator

Rick Rothstein

MrExcel MVP

Rick Rothstein

MrExcel MVP

Similar threads

Forum statistics

Share this page

Concatenate (join cell values) based on other cell values

New Member

New Member

Excel Facts

MrExcel MVP, Moderator

New Member

MrExcel MVP, Moderator

MrExcel MVP

MrExcel MVP, Moderator

MrExcel MVP

MrExcel MVP

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