VBA for copy data from one sheet to another

L

luckykamal26

New Member
Joined
Aug 25, 2020
Messages
4
Office Version
  1. 365
Platform
  1. Windows
Hi,

I have the below data in "sheet1"
ProviderNumber Of TasksNumber of OLA FulfilledPriorityOLA Fulfilled %
Pbonk
2​
1​
Prio 2
50%​
Fiscal
3​
0​
Prio 2
0%​
Pbonk
12​
7​
Prio 1
58%​
Fiscal
1​
0​
Prio 1
0%​
Fiscal
10​
3​
Prio 3
30%​
Pbonk
82​
59​
Prio 1
72%​
Fiscal
14​
1​
Prio 1
7%​
Pbonk
87​
23​
Prio 3
26%​

I want a VBA for the data to be looked in the following way in "sheet2". Is there a way / VBA or pivot way to do so:

ProviderPrio 1OLA 1 FulfilledOLA 1 Fulfilled %Prio 2OLA 2 FulfilledOLA 2 Fulfilled %Prio 3OLA 3 FulfilledOLA 3 Fulfilled %OverallOverall FulfilledOLA % Fulfilled
Pbonk
94​
66​
70.21%​
2​
1​
50.00%​
87​
23​
26.44%​
183​
90​
49.18%​
Fiscal
15​
1​
6.67%​
3​
0​
0.00%​
10​
3​
30.00%​
28​
4​
14.29%​

Please help.

Thanks
K
 

Excel Facts

Convert text numbers to real numbers
Select a column containing text numbers. Press Alt+D E F to quickly convert text to numbers. Faster than "Convert to Number"
Sort by date Sort by votes
Your thread title is misleading. What you are asking for is a rearrangement and calculation macro. Maybe you should change the thread title.
 
Upvote 0
JLGWhiz said:
Your thread title is misleading. What you are asking for is a rearrangement and calculation macro. Maybe you should change the thread title.
Click to expand...
Thanks for the suggestion. I am posting here for the first time. Could you please let me know how to edit the thread title? I am unable to find it to edit.
 
Upvote 0
I don't believe this forum provides a means to do that. I am still looking at your screen shot of the worksheets and if I come up with anything, I will post to this thread. It is a little more complex than just copying. also I was wondering if there will be a lot of cases where the priorities are the sam for more than one entry and will need to be combined? Also will there only be priority 1 - 3?
 
Upvote 0
JLGWhiz said:
I don't believe this forum provides a means to do that. I am still looking at your screen shot of the worksheets and if I come up with anything, I will post to this thread. It is a little more complex than just copying. also I was wondering if there will be a lot of cases where the priorities are the sam for more than one entry and will need to be combined? Also will there only be priority 1 - 3?
Click to expand...
Thanks for understanding. As of now, I have only 3 prio. yes there can be more providers. as of now the number of prior are 1,2 and 3.
 
Upvote 0
See if you can work with this.
VBA Code: 
Sub t()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, c As Range, fn As Range, adr As String
Set sh1 = Sheets("Sheet1") 'Edit sheet name - source
Set sh2 = Sheets("Sheet2") 'Edit sheet name - destination
Set sh3 = Sheets.Add(After:=Sheets(Sheets.Count))
sh1.UsedRange.Copy sh3.Range("A1")
With sh3
    .UsedRange.Sort .Range("A1"), xlAscending, .Range("D1"), , xlAscending, Header:=xlYes
    For i = .Cells(Rows.Count, 1).End(xlUp).Row To 3 Step -1
        If .Cells(i, 1).Value = .Cells(i - 1, 1).Value And .Cells(i, 4).Value = .Cells(i - 1, 4).Value Then
            .Cells(i - 1, 2) = .Cells(i - 1, 2).Value + .Cells(i, 2).Value
            .Cells(i - 1, 3) = .Cells(i - 1, 3).Value + .Cells(i, 3).Value
            .Cells(i - 1, 5) = .Cells(i - 1, 3).Value / .Cells(i - 1, 2).Value
            Rows(i).Delete
        End If
    Next
End With
sh3.Range("A1", sh3.Cells(Rows.Count, 1).End(xlUp)).AdvancedFilter xlFilterCopy, , sh2.Range("A1")
    With sh2
        .Range("A1").ClearContents
        If Application.CountA(.Rows(1)) = 0 Then
            .Range("A1") = "Provider"
            .Range("B1") = "Prio 1"
            .Range("C1, F1, I1") = "OLA 1 Fulfilled"
            .Range("D1, G1, J1") = "OLA 1 Fulfilled %"
            .Range("E1") = "Prio 2"
            .Range("H1") = "Prio 3"
        End If
        For Each c In .Range("A2", .Cells(Rows.Count, 1).End(xlUp))
            Set fn = sh3.Range("A:A").Find(c.Value, , xlValues, xlWhole)
                If Not fn Is Nothing Then
                    adr = fn.Address
                    Do
                        If fn.Offset(, 3).Value = "Prio 1" Then
                            c.Offset(, 1) = fn.Offset(, 1).Value
                            c.Offset(, 2) = fn.Offset(, 2).Value
                            c.Offset(, 3) = fn.Offset(, 4).Value
                        ElseIf fn.Offset(, 3).Value = "Prio 2" Then
                            c.Offset(, 4) = fn.Offset(, 1).Value
                            c.Offset(, 5) = fn.Offset(, 2).Value
                            c.Offset(, 6) = fn.Offset(, 4).Value
                        ElseIf fn.Offset(, 3).Value = "Prio 3" Then
                            c.Offset(, 7) = fn.Offset(, 1).Value
                            c.Offset(, 8) = fn.Offset(, 2).Value
                            c.Offset(, 9) = fn.Offset(, 4).Value
                        End If
                        Set fn = sh3.Range("A:A").FindNext(fn)
                    Loop While fn.Address <> adr
                End If
        Next
    End With
Application.DisplayAlerts = False
sh3.Delete
Application.DisplayAlerts = True
End Sub

If you have errors, note the message and click the debug button to see which line of code the error occurred on. The code ran without error in test set up.
 
Upvote 0
I just saw a glitch, and am working on it. The output is repeating the summary data. I will post the fix when I figure out what is happening.
 
Upvote 0
Amazing what a difference one little word makes. This modified version should now do what you want.

VBA Code: 
Sub t2()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, c As Range, fn As Range, adr As String
Set sh1 = Sheets("Sheet1") 'Edit sheet name - source
Set sh2 = Sheets("Sheet2") 'Edit sheet name - destination
Set sh3 = Sheets.Add(After:=Sheets(Sheets.Count))
sh1.UsedRange.Copy sh3.Range("A1")
With sh3
    .UsedRange.Sort .Range("A1"), xlAscending, .Range("D1"), , xlAscending, Header:=xlYes
    For i = .Cells(Rows.Count, 1).End(xlUp).Row To 3 Step -1
        If .Cells(i, 1).Value = .Cells(i - 1, 1).Value And .Cells(i, 4).Value = .Cells(i - 1, 4).Value Then
            .Cells(i - 1, 2) = .Cells(i - 1, 2).Value + .Cells(i, 2).Value
            .Cells(i - 1, 3) = .Cells(i - 1, 3).Value + .Cells(i, 3).Value
            .Cells(i - 1, 5) = .Cells(i - 1, 3).Value / .Cells(i - 1, 2).Value
            Rows(i).Delete
        End If
    Next
End With
sh3.Range("A1", sh3.Cells(Rows.Count, 1).End(xlUp)).AdvancedFilter xlFilterCopy, , sh2.Range("A1"), True
    With sh2
        .Range("A1").ClearContents
        If Application.CountA(.Rows(1)) = 0 Then
            .Range("A1") = "Provider"
            .Range("B1") = "Prio 1"
            .Range("C1, F1, I1") = "OLA 1 Fulfilled"
            .Range("D1, G1, J1") = "OLA 1 Fulfilled %"
            .Range("E1") = "Prio 2"
            .Range("H1") = "Prio 3"
        Else
           .Range("A1") = "Provider")
        End If
        For Each c In .Range("A2", .Cells(Rows.Count, 1).End(xlUp))
            Set fn = sh3.Range("A:A").Find(c.Value, , xlValues, xlWhole)
                If Not fn Is Nothing Then
                    adr = fn.Address
                    Do
                        If fn.Offset(, 3).Value = "Prio 1" Then
                            c.Offset(, 1) = fn.Offset(, 1).Value
                            c.Offset(, 2) = fn.Offset(, 2).Value
                            c.Offset(, 3) = fn.Offset(, 4).Value
                        ElseIf fn.Offset(, 3).Value = "Prio 2" Then
                            c.Offset(, 4) = fn.Offset(, 1).Value
                            c.Offset(, 5) = fn.Offset(, 2).Value
                            c.Offset(, 6) = fn.Offset(, 4).Value
                        ElseIf fn.Offset(, 3).Value = "Prio 3" Then
                            c.Offset(, 7) = fn.Offset(, 1).Value
                            c.Offset(, 8) = fn.Offset(, 2).Value
                            c.Offset(, 9) = fn.Offset(, 4).Value
                        End If
                        Set fn = sh3.Range("A:A").FindNext(fn)
                    Loop While fn.Address <> adr
                End If
        Next
    End With
Application.DisplayAlerts = False
sh3.Delete
Application.DisplayAlerts = True
End Sub
 
Last edited:
Upvote 0
JLGWhiz said:
Amazing what a difference one little word makes. This modified version should now do what you want.

VBA Code: 
Sub t2()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, c As Range, fn As Range, adr As String
Set sh1 = Sheets("Sheet1") 'Edit sheet name - source
Set sh2 = Sheets("Sheet2") 'Edit sheet name - destination
Set sh3 = Sheets.Add(After:=Sheets(Sheets.Count))
sh1.UsedRange.Copy sh3.Range("A1")
With sh3
    .UsedRange.Sort .Range("A1"), xlAscending, .Range("D1"), , xlAscending, Header:=xlYes
    For i = .Cells(Rows.Count, 1).End(xlUp).Row To 3 Step -1
        If .Cells(i, 1).Value = .Cells(i - 1, 1).Value And .Cells(i, 4).Value = .Cells(i - 1, 4).Value Then
            .Cells(i - 1, 2) = .Cells(i - 1, 2).Value + .Cells(i, 2).Value
            .Cells(i - 1, 3) = .Cells(i - 1, 3).Value + .Cells(i, 3).Value
            .Cells(i - 1, 5) = .Cells(i - 1, 3).Value / .Cells(i - 1, 2).Value
            Rows(i).Delete
        End If
    Next
End With
sh3.Range("A1", sh3.Cells(Rows.Count, 1).End(xlUp)).AdvancedFilter xlFilterCopy, , sh2.Range("A1"), True
    With sh2
        .Range("A1").ClearContents
        If Application.CountA(.Rows(1)) = 0 Then
            .Range("A1") = "Provider"
            .Range("B1") = "Prio 1"
            .Range("C1, F1, I1") = "OLA 1 Fulfilled"
            .Range("D1, G1, J1") = "OLA 1 Fulfilled %"
            .Range("E1") = "Prio 2"
            .Range("H1") = "Prio 3"
        Else
           .Range("A1") = "Provider")
        End If
        For Each c In .Range("A2", .Cells(Rows.Count, 1).End(xlUp))
            Set fn = sh3.Range("A:A").Find(c.Value, , xlValues, xlWhole)
                If Not fn Is Nothing Then
                    adr = fn.Address
                    Do
                        If fn.Offset(, 3).Value = "Prio 1" Then
                            c.Offset(, 1) = fn.Offset(, 1).Value
                            c.Offset(, 2) = fn.Offset(, 2).Value
                            c.Offset(, 3) = fn.Offset(, 4).Value
                        ElseIf fn.Offset(, 3).Value = "Prio 2" Then
                            c.Offset(, 4) = fn.Offset(, 1).Value
                            c.Offset(, 5) = fn.Offset(, 2).Value
                            c.Offset(, 6) = fn.Offset(, 4).Value
                        ElseIf fn.Offset(, 3).Value = "Prio 3" Then
                            c.Offset(, 7) = fn.Offset(, 1).Value
                            c.Offset(, 8) = fn.Offset(, 2).Value
                            c.Offset(, 9) = fn.Offset(, 4).Value
                        End If
                        Set fn = sh3.Range("A:A").FindNext(fn)
                    Loop While fn.Address <> adr
                End If
        Next
    End With
Application.DisplayAlerts = False
sh3.Delete
Application.DisplayAlerts = True
End Sub
Click to expand...
Wow Wow Wow....That is great help. I will run the code and make necessary changes if required. Thanks a ton once again.
 
Upvote 0
You must log in or register to reply here.

Similar threads

N
  • Question
VBA Questions - Copying dynamic data from one tab to another and deleting filtered rows
Replies
1
Views
185
DanteAmor
DanteAmor
M
  • Solved
VBA Transpose data from one sheet into another
Replies
9
Views
286
madi1004
M
J
  • Solved
Calculate last 5 soccer team goals using data from another sheet on same workbook.
2
Replies
19
Views
907
felixstraube
F
B
  • Question
Copy Paste from one Workbook to another
Replies
1
Views
217
rollis13
rollis13
C
  • Question
Find duplicates when pulling data from other sheets
Replies
3
Views
176
Trebor76
T

Forum statistics

Threads
1,214,978
Messages
6,122,549
Members
449,089
Latest member
davidcom

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