Transpose cells separated with "," and duplicate data in rows

S

SVDCF

New Member
Joined
Jul 20, 2016
Messages
7
Hello everyone!

I am new to this forum and I would like to raise a question regarding the thread :
http://www.mrexcel.com/forum/excel-...utomatically-insert-new-rows.html#post4521996

I would like to do this same operation but the column I want to replicate is in column "HT".

How can I change this macro do to the transpose in column "HT"?

Additionally, why I am always getting the following error "Mismatch" highlighting the "Sheets("sheet1").Range("a1").Resize(c, UBound(Ray, 2)) = Application.Transpose(nray)".

I have no idea how to correct it.

Appreciated!

K.Regards
Sara


Sub som()
Dim Ray As Variant, n As Long, Sp As Variant, c As Long, s As Long, Ac As Long
Ray = ActiveSheet.Range("A1").CurrentRegion
ReDim nray(1 To UBound(Ray, 2), 1 To 1)


For n = 1 To UBound(Ray, 1)
Sp = Split(Ray(n, 2), ",")
For s = 0 To UBound(Sp)
c = c + 1
ReDim Preserve nray(1 To UBound(Ray, 2), 1 To c)
For Ac = 1 To UBound(Ray, 2)
If Ac = 2 Then
nray(Ac, c) = Sp(s)
Else
nray(Ac, c) = Ray(n, Ac)
End If
Next Ac
Next s
Next n
Sheets("sheet1").Range("a1").Resize(c, UBound(Ray, 2)) = Application.Transpose(nray)
MsgBox "Run"
End Sub
 
Sort by date Sort by votes
sheetspread said:
Without knowing where your columns start, I tried this and it worked:

Excel 2010
HTHUHVHWHX
1Cust partOur partsOur IDCurrencyPrice
2135649A1, A75262Part AD1E+08USD$18.95
3138642, BN98510, 190585R91Part O1E+08USD$7.82
4163044, BN98509Part W1E+08USD$4.57
5179080, BSET2Part U1E+08USD$3.97
618427, ST791Part P1E+08USD$7.82
721076D, E3NN3123AA, 210760Part N1E+08USD$3.66
844401, 694735 CONE, ST775APart C1E+08USD$6.44
9459456R91, 86576982 - CONE, 273423Part L1E+08USD$3.83
1047508360, 52443, 664175R92Part F1E+08USD$13.22

<colgroup><col style="width: 25pxpx"><col><col><col><col><col></colgroup><thead>
</thead><tbody>
</tbody>
Sheet3 (3)​



Code: 
Sub parsetranspose()
Dim x%, y%, partarray As Variant
x = 2
Do Until Cells(x, 228).Value = ""
y = Len(Cells(x, 228)) - Len(Replace(Cells(x, 228).Value, ",", ""))
If y > 0 Then
ReDim partarray(y)
partarray = Split(Cells(x, 228).Value, ",")
Rows(x + 1).Resize(y).Insert
Range("HT" & x).Resize(y + 1).Value = Application.Transpose(partarray)
Range("HU" & x & ":HX" & x).Resize(y + 1).Value = Range("HU" & x & ":HX" & x).Value
Else
End If
x = x + y + 1
Loop
End Sub

Excel 2010
HTHUHVHWHX
1Cust partOur partsOur IDCurrencyPrice
2135649A1Part AD100110399USD$18.95
3 A75262Part AD100110399USD$18.95
4138642Part O100027144USD$7.82
5 BN98510Part O100027144USD$7.82
6 190585R91Part O100027144USD$7.82
7163044Part W100026523USD$4.57
8 BN98509Part W100026523USD$4.57
9179080Part U100045902USD$3.97
10 BSET2Part U100045902USD$3.97
1118427Part P100047915USD$7.82
12 ST791Part P100047915USD$7.82
1321076DPart N100050683USD$3.66
14 E3NN3123AAPart N100050683USD$3.66
15210760Part N100050683USD$3.66
1644401Part C100055719USD$6.44
17 694735 CONEPart C100055719USD$6.44
18 ST775APart C100055719USD$6.44
19459456R91Part L100096658USD$3.83
20 86576982 - CONEPart L100096658USD$3.83
21273423Part L100096658USD$3.83
2247508360Part F100081326USD$13.22
2352443Part F100081326USD$13.22
24 664175R92Part F100081326USD$13.22

<colgroup><col style="width: 25pxpx"><col><col><col><col><col></colgroup><thead>
</thead><tbody>
</tbody>
Sheet3 (3)​
Click to expand...

It does everything I need apart from copying :(
 
Upvote 0

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).
sheetspread said:
Will a few extra code lines that copy and paste the range to where you want then expand be enough?
Click to expand...

Please :) the macro works perfectly exept that part.

What i get is something like this:


HTHUHVHWHX
1Cust partOur partsOur IDCurrencyPrice
2135649A1Part AD100110399USD$18.95
3A75262
4138642Part O100027144USD$7.82
5BN98510
6190585R91Part O100027144USD$7.82
7163044Part W100026523USD$4.57
8BN98509
9179080Part U100045902USD$3.97
10BSET2
1118427Part P100047915USD$7.82
12ST791
1321076DPart N100050683USD$3.66
14E3NN3123AA
15210760Part N100050683USD$3.66
1644401Part C100055719USD$6.44
17694735 CONE
18ST775APart C100055719USD$6.44
19459456R91Part L100096658USD$3.83
2086576982 - CONE

<thead>
</thead><tbody>
</tbody>


HTHUHVHWHX
1Cust partOur partsOur IDCurrencyPrice
2135649A1Part AD100110399USD$18.95
3A75262Part AD100110399USD$18.95
4138642Part O100027144USD$7.82
5BN98510Part O100027144USD$7.82
6190585R91Part O100027144USD$7.82
7163044Part W100026523USD$4.57
8BN98509Part W100026523USD$4.57
9179080Part U100045902USD$3.97
10BSET2Part U100045902USD$3.97
1118427Part P100047915USD$7.82
12ST791Part P100047915USD$7.82
1321076DPart N100050683USD$3.66
14E3NN3123AAPart N100050683USD$3.66
15210760Part N100050683USD$3.66
1644401Part C100055719USD$6.44
17694735 CONEPart C100055719USD$6.44
18ST775APart C100055719USD$6.44
19459456R91Part L100096658USD$3.83
2086576982 - CONEPart L100096658USD$3.83
21273423Part L100096658USD$3.83
2247508360Part F100081326USD$13.22
2352443Part F100081326USD$13.22
24664175R92Part F100081326USD$13.22

<thead>
</thead><tbody>
</tbody>
 
Last edited by a moderator:
Upvote 0
Wait forget what I just wrote, it will still insert the rows unless you paste it below your data then move it back up, I'll post another method.
 
Last edited:
Upvote 0
See if this works:


Excel 2010
HTHUHVHWHX
1Cust partOur partsOur IDCurrencyPrice
2135649A1, A75262Part AD100110399USD$18.95
3138642, BN98510, 190585R91Part O100027144USD$7.82
4163044, BN98509Part W100026523USD$4.57
5179080, BSET2Part U100045902USD$3.97
618427, ST791Part P100047915USD$7.82
721076D, E3NN3123AA, 210760Part N100050683USD$3.66
844401, 694735 CONE, ST775APart C100055719USD$6.44
9459456R91, 86576982 - CONE, 273423Part L100096658USD$3.83
1047508360, 52443, 664175R92Part F100081326USD$13.22
Sheet3 (8)


Code: 
Sub parsetranspose()
Dim x%, y%, z%, partarray As Variant
x = 2
z = 2
Range("HZ1").Resize(, 5).Value = Range("HT1").Resize(, 5).Value
Do Until Cells(x, 228).Value = ""
y = Len(Cells(x, 228)) - Len(Replace(Cells(x, 228).Value, ",", ""))
Range("HZ" & z & ":ID" & z).Resize(y + 1).Value = Range("HT" & x & ":HX" & x).Value
If y > 0 Then
ReDim partarray(y)
partarray = Split(Cells(x, 228).Value, ",")
Range("HZ" & z).Resize(y + 1).Value = Application.Transpose(partarray)
Else
End If
x = x + 1
z = z + y + 1
Loop
End Sub


Excel 2010
HTHUHVHWHXHYHZIAIBICID
1Cust partOur partsOur IDCurrencyPriceCust partOur partsOur IDCurrencyPrice
2135649A1, A75262Part AD100110399USD$18.95135649A1Part AD100110399USD18.95
3138642, BN98510, 190585R91Part O100027144USD$7.82A75262Part AD100110399USD18.95
4163044, BN98509Part W100026523USD$4.57138642Part O100027144USD7.82
5179080, BSET2Part U100045902USD$3.97BN98510Part O100027144USD7.82
618427, ST791Part P100047915USD$7.82190585R91Part O100027144USD7.82
721076D, E3NN3123AA, 210760Part N100050683USD$3.66163044Part W100026523USD4.57
844401, 694735 CONE, ST775APart C100055719USD$6.44BN98509Part W100026523USD4.57
9459456R91, 86576982 - CONE, 273423Part L100096658USD$3.83179080Part U100045902USD3.97
1047508360, 52443, 664175R92Part F100081326USD$13.22BSET2Part U100045902USD3.97
1118427Part P100047915USD7.82
12ST791Part P100047915USD7.82
1321076DPart N100050683USD3.66
14E3NN3123AAPart N100050683USD3.66
15210760Part N100050683USD3.66
1644401Part C100055719USD6.44
17694735 CONEPart C100055719USD6.44
18ST775APart C100055719USD6.44
19459456R91Part L100096658USD3.83
2086576982 - CONEPart L100096658USD3.83
21273423Part L100096658USD3.83
2247508360Part F100081326USD13.22
2352443Part F100081326USD13.22
24664175R92Part F100081326USD13.22
Sheet3 (8)
 
Upvote 0
Hello!!!!

I did a little change to your code and it works so well!!!

Many many thanks for your help!



Sub transpose()
Dim x%, y%, partarray As Variant, oCell As Range
x = 2
Do Until Cells(x, 228).Value = ""
y = Len(Cells(x, 228)) - Len(Replace(Cells(x, 228).Value, ",", ""))
If y > 0 Then
ReDim partarray(y)
partarray = Split(Cells(x, 228).Value, ",")
Rows(x).Copy
Rows(x + 1).Resize(y).Insert
Range("HT" & x).Resize(y + 1).Value = Application.transpose(partarray)

Range("HU" & x & ":HX" & x).Resize(y + 1).Value = Range("HU" & x & ":HX" & x).Value


Else
End If
x = x + y + 1
Loop
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question
select value two columns to the left of variable in an array
Replies
1
Views
241
myall_blues
myall_blues
I
  • Solved
Irregular Data Set
2
Replies
19
Views
273
IdabaMalouki
I
N
  • Question
VBA Transpose & Join Help
Replies
5
Views
301
Alex Blakenburg
A
rjplante
  • Solved
sort numbers with letters
2 3
Replies
24
Views
1K
Akuini
Akuini
K
  • Solved
Previously working very complex VBA now stopped
Replies
7
Views
457
Alex Blakenburg
A

Forum statistics

Threads
1,221,531
Messages
6,160,379
Members
451,642
Latest member
mirofa

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top