Concatenate with obstacles

[olfleck]

Hi,
I have the following excerpt from a system (Table 1). However I need to change this input and make it look like the Table 2.
The data is not very homogenous, which makes it very troublesome to use the CONCATENATE or any other Function. Sometimes the system can only find old data (see company B) so then I have to work with this. Sometimes it puts Geographic Segments and says they are 0(-) as you can see with company A below, which should not be in the output.
It usually is more than 3 companies and each of them can have various numbers of segments they operate in.

The output for each company should look like the following:
Segment 1 (Percentage), Segment 2 (Percentage),...

Can anyone help me to write a macro that solves this problem?

Let me know if something is not clear and thank you in advance!

Table 1 (INPUT)

	Company Name	Geographic Segments	2016	2015
1	A	United States	54.5%	-
2	A	Canada	6.8%	-
3	A	China	4.9%	-
4	A	Germany	4.4%	-
5	A	All Other	29.4%	-
6	A	United Kingdom	-	-
7	A	Netherlands	-	-
	Company Name	Geographic Segments	2016	2015
1	B	East China	-	12.4%
2	B	Southern China	-	78.0%
3	B	Central China	-	3.9%
	Company Name	Geographic Segments	2016	2015
1	C	Canada	-	3.4%
2	C	United Kingdom	-	2.1%
3	C	Switzerland	-	-
4	C	Brazil	-	1.0%
5	C	Mexico	-	0.9%

<colgroup><col><col><col><col span="2"></colgroup><tbody>
</tbody>

OUTPUT:

Company Name	Geographic Segments
A	United States (54.5%), All Other (29.4%), Canada (6.8%), China (4.9%), Germany (4.4%)
B	Southern China (78%), East China (12.4%), Central China (3.9%)
C	Canada (3.4%), United Kingdom (2.1%), Brazil (1%), Mexico (0.9%)

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

 

[olfleck]

Company name is in C.
Geographic segment is in E and the 2016 data in F and the 2015 data in G.

EDIT: I simplified it. The headers (Business Segment, Company Name, 2016, 2015) of the real table start in row 7 and the columns are the way I wrote it above.

 

[Rick Rothstein]

Company name is in C.
Geographic segment is in E and the 2016 data in F and the 2015 data in G.

EDIT: I simplified it. The headers (Business Segment, Company Name, 2016, 2015) of the real table start in row 7 and the columns are the way I wrote it above.

Okay, for the layout you told us about above, the macro below should produce the output you want. Note that I set the output to go to Sheet2 starting at cell A1... if that is wrong, change the appropriate part of the code that I highlighted in red to the correct destination.

[table="width: 500"]
[tr]
	[td]Sub RearrangeData()
  Dim X As Long, R As Long, Rng As Range, FirstOutputCell As Range, Ar As Variant, Joined As String, Result As Variant
  Set Rng = Intersect(Range("C7", Cells(Rows.Count, "C").End(xlUp)).SpecialCells(xlConstants).EntireRow, Columns("C:G"))
  Set FirstOutputCell = Sheets("[COLOR="#FF0000"]Sheet2[/COLOR]").Range("[COLOR="#FF0000"]A1[/COLOR]")
  ReDim Result(1 To Rng.Areas.Count, 1 To 2)
  For X = 1 To Rng.Areas.Count
    Ar = Rng.Areas(X)
    Result(X, 1) = Ar(2, 1)
    For R = 2 To UBound(Ar)
      Joined = Replace(Ar(R, 4) & Ar(R, 5), "-", "")
      If Len(Joined) Then Result(X, 2) = Result(X, 2) & ", " & Ar(R, 3) & " (" & Format(100 * Joined, "General Number") & "%)"
    Next
    Result(X, 2) = Mid(Result(X, 2), 3)
  Next
  FirstOutputCell.Resize(, 2) = Rng(1).Resize(, 2).Value
  FirstOutputCell.Offset(1).Resize(UBound(Result), 2) = Result
  FirstOutputCell.Resize(, 2).EntireColumn.AutoFit
End Sub[/td]
[/tr]
[/table]

 

[olfleck]

Okay, for the layout you told us about above, the macro below should produce the output you want. Note that I set the output to go to Sheet2 starting at cell A1... if that is wrong, change the appropriate part of the code that I highlighted in red to the correct destination.

[TABLE="width: 500"]
<tbody>[TR]
[TD]Sub RearrangeData()
  Dim X As Long, R As Long, Rng As Range, FirstOutputCell As Range, Ar As Variant, Joined As String, Result As Variant
  Set Rng = Intersect(Range("C7", Cells(Rows.Count, "C").End(xlUp)).SpecialCells(xlConstants).EntireRow, Columns("C:G"))
  Set FirstOutputCell = Sheets("[COLOR=#FF0000]Sheet2[/COLOR]").Range("[COLOR=#FF0000]A1[/COLOR]")
  ReDim Result(1 To Rng.Areas.Count, 1 To 2)
  For X = 1 To Rng.Areas.Count
    Ar = Rng.Areas(X)
    Result(X, 1) = Ar(2, 1)
    For R = 2 To UBound(Ar)
      Joined = Replace(Ar(R, 4) & Ar(R, 5), "-", "")
      If Len(Joined) Then Result(X, 2) = Result(X, 2) & ", " & Ar(R, 3) & " (" & Format(100 * Joined, "General Number") & "%)"
    Next
    Result(X, 2) = Mid(Result(X, 2), 3)
  Next
  FirstOutputCell.Resize(, 2) = Rng(1).Resize(, 2).Value
  FirstOutputCell.Offset(1).Resize(UBound(Result), 2) = Result
  FirstOutputCell.Resize(, 2).EntireColumn.AutoFit
End Sub[/TD]
[/TR]
</tbody>[/TABLE]

Works really well! It just occasionally turns the value into a 5 or 6 number figure, for example 31307.3% instead of 31.3%.

 

[olfleck]

Ok I just have to round the values then it works. Thank you so much for this!!

 

[olfleck]

Okay, for the layout you told us about above, the macro below should produce the output you want. Note that I set the output to go to Sheet2 starting at cell A1... if that is wrong, change the appropriate part of the code that I highlighted in red to the correct destination.

[TABLE="width: 500"]
<tbody>[TR]
[TD]Sub RearrangeData()
  Dim X As Long, R As Long, Rng As Range, FirstOutputCell As Range, Ar As Variant, Joined As String, Result As Variant
  Set Rng = Intersect(Range("C7", Cells(Rows.Count, "C").End(xlUp)).SpecialCells(xlConstants).EntireRow, Columns("C:G"))
  Set FirstOutputCell = Sheets("[COLOR=#FF0000]Sheet2[/COLOR]").Range("[COLOR=#FF0000]A1[/COLOR]")
  ReDim Result(1 To Rng.Areas.Count, 1 To 2)
  For X = 1 To Rng.Areas.Count
    Ar = Rng.Areas(X)
    Result(X, 1) = Ar(2, 1)
    For R = 2 To UBound(Ar)
      Joined = Replace(Ar(R, 4) & Ar(R, 5), "-", "")
      If Len(Joined) Then Result(X, 2) = Result(X, 2) & ", " & Ar(R, 3) & " (" & Format(100 * Joined, "General Number") & "%)"
    Next
    Result(X, 2) = Mid(Result(X, 2), 3)
  Next
  FirstOutputCell.Resize(, 2) = Rng(1).Resize(, 2).Value
  FirstOutputCell.Offset(1).Resize(UBound(Result), 2) = Result
  FirstOutputCell.Resize(, 2).EntireColumn.AutoFit
End Sub[/TD]
[/TR]
</tbody>[/TABLE]

Hey Rick sorry to bother you again with this but I've come across a problem. I've come across tables that I need to work on that include negative values... Is there a way to amend the code so it can also include values that are negative?

 

[Rick Rothstein]

Hey Rick sorry to bother you again with this but I've come across a problem. I've come across tables that I need to work on that include negative values... Is there a way to amend the code so it can also include values that are negative?

This modified version of my previous code should work for you...

[table="width: 500"]
[tr]
	[td]Sub RearrangeData()
  Dim X As Long, R As Long, Rng As Range, FirstOutputCell As Range, Ar As Variant, Joined As String, Result As Variant
  Set Rng = Intersect(Range("C7", Cells(Rows.Count, "C").End(xlUp)).SpecialCells(xlConstants).EntireRow, Columns("C:G"))
  Set FirstOutputCell = Sheets("Sheet2").Range("A1")
  ReDim Result(1 To Rng.Areas.Count, 1 To 2)
  For X = 1 To Rng.Areas.Count
    Ar = Rng.Areas(X)
    Result(X, 1) = Ar(2, 1)
    For R = 2 To UBound(Ar)
      If Ar(R, 4) = "-" Then Ar(R, 4) = ""
      If Ar(R, 5) = "-" Then Ar(R, 5) = ""
      Joined = Ar(R, 4) & Ar(R, 5)
      If Len(Joined) Then Result(X, 2) = Result(X, 2) & ", " & Ar(R, 3) & " (" & Format(100 * Joined, "General Number") & "%)"
    Next
    Result(X, 2) = Mid(Result(X, 2), 3)
  Next
  FirstOutputCell.Resize(, 2) = Rng(1).Resize(, 2).Value
  FirstOutputCell.Offset(1).Resize(UBound(Result), 2) = Result
  FirstOutputCell.Resize(, 2).EntireColumn.AutoFit
End Sub[/td]
[/tr]
[/table]