In need of some VBA wizardry please.

G

GAJITCS

Board Regular
Joined
Apr 21, 2015
Messages
66
I have a table that looks a bit like the one below (dummy data)


ASC.25.5.75123456
A1AAAAAAAAAAAAAAAAAAAABBBBBBBBAAAAAAAA
2BAAAAAAAABBBBAAAAAAAAAAAAAAAAAAAABBBB
2CBBBBBBBBBBBBBBBBPOAPOABBBBCCCCCCCC
3CCCCCDDDDDDDDAAAAPOACCCCBBBBCCCCDDDD
4DPOACCCCCCCCPOAEEEEDDDDDDDDEEEEEEEE

There are actually 254 rows and 33 Weight columns.

The data in the first row is header data and refers to Weights.
The data in the first column refers to a Destination.
The data in the table in what looks like B2:J6 are Services.

I need to end up with this data turned into a list as shown below.

DestinationPUDWeight FromWeight ToService
A10.012AAAA
A12.014BBBB
A14.016AAAA
2B0.010.5AAAA
2B0.510.75BBBB
2B0.765AAAA
2C0.011BBBB
2C3.014BBBB
2C4.016CCCC
3C0.010.25CCCC
3C.0260.75DDDD
3C0.761AAAA
3C2.013CCCC
3C3.014BBBB
3C4.015CCCC
3C5.016DDDD
4D.0260.75CCCC
4D1.012EEEE
4D2.014DDDD
4D4.016EEEE

For each row, where a Service exists under a weight band, the Service is deemed to deliver items upto the Weight listed to the Destination. Thus, for Destination A1, it is delivered to by Service AAAA for all deliveries from 0.01 (0.01 above previous weight band) to the weight band last weight band before the cell value changes, 0.01 to 2. There is a change of Service at 3 and again at 5. So, for Destination A1, there are three rows in the new output table.

Where POA is listed, no service is in place and the weight is skipped. For Destination 2C though, the entries are listed as 2C - 0.01 - 1 BBBB and then 2C - 3.01 - 4.00 BBBB as there are entries of POA between the two sets of Service of BBBB for Weights 2 and 3.

The data in the first table is dynamic and will change from day to day.

What I would like help with is the efficient VBA code that can convert from my table into the desired output format.

Happy to provide further information if my first explanation needs clarification.

Many thanks for your time and effort.
 

Excel Facts

Copy a format multiple times
Select a formatted range. Double-click the Format Painter (left side of Home tab). You can paste formatting multiple times. Esc to stop
Sort by date Sort by votes
How about
VBA Code: 
Sub Gajitcs()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, c As Long, nr As Long
   Dim Tmp As String
   Dim Wght As Double
   
   Ary = Sheets("Sheet1").Range("A1").CurrentRegion.Value2
   ReDim Nary(1 To UBound(Ary) * UBound(Ary, 2), 1 To 5)
   
   For r = 2 To UBound(Ary)
      Wght = 0.01
      For c = 2 To UBound(Ary, 2)
         If Ary(r, c) <> "POA" Then
            If Ary(r, c) <> Tmp Then
               Tmp = Ary(r, c)
               nr = nr + 1
               Nary(nr, 1) = Ary(r, 1)
               Nary(nr, 3) = Wght
               Nary(nr, 4) = Ary(1, c)
               Nary(nr, 5) = Ary(r, c)
               Wght = Ary(1, c) + 0.01
            Else
               Wght = Ary(1, c) + 0.01
               Nary(nr, 4) = Wght - 0.01
            End If
         Else
            Nary(r, 4) = Wght
            Wght = Ary(1, c) + 0.01
            Tmp = Ary(r, c)
         End If
      Next c
      Tmp = ""
   Next r
   Sheets("Sheet2").Range("A2").Resize(nr, 5).Value = Nary
End Sub
 
Upvote 0
Fluff said:
How about
VBA Code: 
Sub Gajitcs()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, c As Long, nr As Long
   Dim Tmp As String
   Dim Wght As Double
  
   Ary = Sheets("Sheet1").Range("A1").CurrentRegion.Value2
   ReDim Nary(1 To UBound(Ary) * UBound(Ary, 2), 1 To 5)
  
   For r = 2 To UBound(Ary)
      Wght = 0.01
      For c = 2 To UBound(Ary, 2)
         If Ary(r, c) <> "POA" Then
            If Ary(r, c) <> Tmp Then
               Tmp = Ary(r, c)
               nr = nr + 1
               Nary(nr, 1) = Ary(r, 1)
               Nary(nr, 3) = Wght
               Nary(nr, 4) = Ary(1, c)
               Nary(nr, 5) = Ary(r, c)
               Wght = Ary(1, c) + 0.01
            Else
               Wght = Ary(1, c) + 0.01
               Nary(nr, 4) = Wght - 0.01
            End If
         Else
            Nary(r, 4) = Wght
            Wght = Ary(1, c) + 0.01
            Tmp = Ary(r, c)
         End If
      Next c
      Tmp = ""
   Next r
   Sheets("Sheet2").Range("A2").Resize(nr, 5).Value = Nary
End Sub
Click to expand...

Many thanks Fluff.

I am trying to work out how the VBA works now. The result the code gives is different from what I expected for just three of the values. The values are those in Sheet2 D5:D7.

VBA is still a form of magic to me. Works so well and quickly. I really should find out more.
 
Upvote 0
Ok, how about
VBA Code: 
Sub Gajitcs()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, c As Long, nr As Long
   Dim Tmp As String
   Dim Wght As Double
   
   Ary = Sheets("Sheet1").Range("A1").CurrentRegion.Value2
   ReDim Nary(1 To UBound(Ary) * UBound(Ary, 2), 1 To 5)
   
   For r = 2 To UBound(Ary)
      Wght = 0.01
      For c = 2 To UBound(Ary, 2)
         If Ary(r, c) <> "POA" Then
            If Ary(r, c) <> Tmp Then
               Tmp = Ary(r, c)
               nr = nr + 1
               Nary(nr, 1) = Ary(r, 1)
               Nary(nr, 3) = Wght
               Nary(nr, 4) = Ary(1, c)
               Nary(nr, 5) = Ary(r, c)
               Wght = Ary(1, c) + 0.01
            Else
               Wght = Ary(1, c) + 0.01
               Nary(nr, 4) = Wght - 0.01
            End If
         Else
            If c > 2 Then Nary(nr, 4) = Wght - 0.01
            Tmp = Ary(r, c)
         End If
      Next c
      Tmp = ""
   Next r
   Sheets("Sheet2").Range("A2").Resize(nr, 5).Value = Nary
End Sub
 
Upvote 0
Fluff said:
Ok, how about
VBA Code: 
Sub Gajitcs()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, c As Long, nr As Long
   Dim Tmp As String
   Dim Wght As Double
  
   Ary = Sheets("Sheet1").Range("A1").CurrentRegion.Value2
   ReDim Nary(1 To UBound(Ary) * UBound(Ary, 2), 1 To 5)
  
   For r = 2 To UBound(Ary)
      Wght = 0.01
      For c = 2 To UBound(Ary, 2)
         If Ary(r, c) <> "POA" Then
            If Ary(r, c) <> Tmp Then
               Tmp = Ary(r, c)
               nr = nr + 1
               Nary(nr, 1) = Ary(r, 1)
               Nary(nr, 3) = Wght
               Nary(nr, 4) = Ary(1, c)
               Nary(nr, 5) = Ary(r, c)
               Wght = Ary(1, c) + 0.01
            Else
               Wght = Ary(1, c) + 0.01
               Nary(nr, 4) = Wght - 0.01
            End If
         Else
            If c > 2 Then Nary(nr, 4) = Wght - 0.01
            Tmp = Ary(r, c)
         End If
      Next c
      Tmp = ""
   Next r
   Sheets("Sheet2").Range("A2").Resize(nr, 5).Value = Nary
End Sub
Click to expand...

Fluff, Thank you.

It solves one problem, but now skips some logic somewhere and mishandles the POA involvement. I will flowchart this in the morning and see what I can work out.
 
Upvote 0
Here is another macro for you to consider.

VBA Code: 
Sub Weights_Columns()
  Dim a As Variant, b As Variant, ant As Variant
  Dim i As Long, j As Long, k As Long, ini As Double

  a = Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, Sheets("Sheet1").Range("A1").CurrentRegion.Columns.Count + 1).Value2
  ReDim b(1 To UBound(a) * UBound(a, 2), 1 To 5)
  
  For i = 2 To UBound(a, 1)
    ant = a(i, 2)
    ini = 0.01
    For j = 2 To UBound(a, 2)
      If ant <> a(i, j) Then
        If ant <> "POA" Then
          k = k + 1
          b(k, 1) = a(i, 1)
          b(k, 3) = ini
          b(k, 4) = a(1, j - 1)
          b(k, 5) = ant
        End If
        ini = a(1, j - 1) + 0.01
      End If
      ant = a(i, j)
    Next j
  Next i
  Sheets("Sheet2").Range("A2").Resize(k, 5).Value = b
End Sub
 
Upvote 0
Solution
DanteAmor said:
Here is another macro for you to consider.

VBA Code: 
Sub Weights_Columns()
  Dim a As Variant, b As Variant, ant As Variant
  Dim i As Long, j As Long, k As Long, ini As Double

  a = Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, Sheets("Sheet1").Range("A1").CurrentRegion.Columns.Count + 1).Value2
  ReDim b(1 To UBound(a) * UBound(a, 2), 1 To 5)
 
  For i = 2 To UBound(a, 1)
    ant = a(i, 2)
    ini = 0.01
    For j = 2 To UBound(a, 2)
      If ant <> a(i, j) Then
        If ant <> "POA" Then
          k = k + 1
          b(k, 1) = a(i, 1)
          b(k, 3) = ini
          b(k, 4) = a(1, j - 1)
          b(k, 5) = ant
        End If
        ini = a(1, j - 1) + 0.01
      End If
      ant = a(i, j)
    Next j
  Next i
  Sheets("Sheet2").Range("A2").Resize(k, 5).Value = b
End Sub
Click to expand...
Many thanks DanteAmour. Sorry for the delayed marking for the solution.

I am looking to adapt this for a slightly different and additional need.

Is there any chance you could add notation for me so I can try to adapt it myself in the first instance please. I don't need to bundle the weight categories together for this one, just pick up each weight and associated service provider.
 
Upvote 0
DanteAmor said:
Here is another macro for you to consider.

VBA Code: 
Sub Weights_Columns()
  Dim a As Variant, b As Variant, ant As Variant
  Dim i As Long, j As Long, k As Long, ini As Double

  a = Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, Sheets("Sheet1").Range("A1").CurrentRegion.Columns.Count + 1).Value2
  ReDim b(1 To UBound(a) * UBound(a, 2), 1 To 5)
 
  For i = 2 To UBound(a, 1)
    ant = a(i, 2)
    ini = 0.01
    For j = 2 To UBound(a, 2)
      If ant <> a(i, j) Then
        If ant <> "POA" Then
          k = k + 1
          b(k, 1) = a(i, 1)
          b(k, 3) = ini
          b(k, 4) = a(1, j - 1)
          b(k, 5) = ant
        End If
        ini = a(1, j - 1) + 0.01
      End If
      ant = a(i, j)
    Next j
  Next i
  Sheets("Sheet2").Range("A2").Resize(k, 5).Value = b
End Sub
Click to expand...
DanteAmor, I am in need of more assistance please.
Ahead of each new value in column A of a row, I need to insert another line in the result of the code you have generated, that I can then fill with other data. That data would populate Columns 1,3,4 and 5 and needs to be, the next value in column A, -1, -1 and the next value in column E
ABCDE
A1
-1​
-1​
AAAA
A1
0.01​
1​
AAAA
A1
1.76​
30​
BBBB
2B
-1​
-1​
AAAA
2B
0.01​
1​
AAAA
2B
1.76​
30​
CCCC
2C
-1​
-1​
BBBB
2C
0.01​
0.5​
BBBB
2C
0.51​
1​
CCCC
2C
1.76​
30​
DDDD
3C
-1​
-1​
AAAA
3C
0.01​
1​
AAAA
3C
1.76​
30​
CCCC
So the new lines here are the first instances of text change in column A. This data doesn't exist in the original array and needs to be injected into the result of the code that you wrote and works so well. Columns C and D will always be "-1" and the data for column E needs t be pulled from the record below.
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
VBA Copy over to Sheet2
Replies
7
Views
249
Stephen_IV
S
A
  • Solved
How to integrate two columns in VBA
2
Replies
12
Views
861
Fluff
Fluff
coolguyvarun01
  • Question
Merge Data from multiple sheets into one by transposing and counting(VBA)
Replies
4
Views
827
Alex Blakenburg
A
S
  • Question
Need help with Data in Subgroup
Replies
4
Views
285
sksanjeev786
S
S
  • Question
VBA Duplicates in a group based on 2 columns
Replies
5
Views
2K
JoeMo
J

Forum statistics

Threads
1,214,834
Messages
6,121,871
Members
449,054
Latest member
juliecooper255

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