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

Why does 9 mean SUM in SUBTOTAL?
It is because Sum is the 9th alphabetically in Average, Count, CountA, Max, Min, Product, StDev.S, StDev.P, Sum, VAR.S, VAR.P.
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

U
  • Question Question
Excel Activate workbook1/sheet, Copy/paste row in workbook2/sheet, activate autofilter, return value and loop
Replies
0
Views
60
user29383902
U
A
  • Question Question
How restrict copy data from form to sheet based on five days within current month
Replies
3
Views
112
Ali M
A
N
  • Solved
Excel 2016 VBA - Pull data from multiple sheets to One with specificities
Replies
3
Views
426
mumps
mumps
G
  • Question Question
Copying date from one sheet to another based on time left
Replies
2
Views
125
Vogateer
V
V
  • Solved
Need VBA to split data into multiple sheets paste formulas, formatting AND data validation
Replies
2
Views
123
vanessavalentino83
V

Forum statistics

Threads
1,224,822
Messages
6,181,165
Members
453,021
Latest member
Justyna P

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