Help with Reformatting/Calculating spreadsheet

Sontauzo

New Member
Joined
Mar 13, 2018
Messages
18
HelloAll,

I am new to the VBA world, but I have beenusing the different threads here to answer some of my more basic questions, buti have kind of a complicated one. Here goes...

I have an Excel spreadsheet that contains usertransaction data for an inventory system that we use. Each row represents aseparate transaction with specific data that needs to be analyzed. Iam trying to use VBA code to pull the relevant data and display it in a newsheet, but I am stuck. The raw data looks something like what is below. The raw data set hasabout 40 columns, and I am having troubles ignoring the extra data andcapturing the relevant stuff.


UserItemTransactionQuantity
TomHammerRemove1
TomNailsRemove40
TomNailsReturn7
MaryWrenchRemove2
MaryHammerRemove4
MaryWrenchReturn1
SamNailsRemove60
SamNailsReturn35
BillHammerRemove2
BillHammerRemove7
FredHammerRemove1
FredNailsRemove25
FredWrenchRemove4
FredNailsReturn1

<tbody>
</tbody>


Here is the kind of output that I am looking for.

UserItemQuantity
Tom
Hammer1
Nails33
Mary
Wrench1
Hammer4
Sam
Nails25
Bill
Hammer9
Fred
Hammer1
Nails24
Wrench4

<tbody>
</tbody>

I don't know if what I asking is even possible, but I am stumped and wanted to get some outside help.

Thanks in advance for you time and consideration.

BWL
 

Excel Facts

Best way to learn Power Query?
Read M is for (Data) Monkey book by Ken Puls and Miguel Escobar. It is the complete guide to Power Query.
Hi & welcome to the board
How about
Code:
Sub RearrangeData()

   Dim Dic As Object
   Dim Cl As Range
   Dim v1 As String, v2 As String
   Dim v3 As Long
   Dim Ky1 As Variant
   Dim Ws1 As Worksheet, Ws2 As Worksheet
   Dim NxtRw As Long
   
   Set Ws1 = Sheets("[COLOR=#ff0000]Upload[/COLOR]")
   Set Ws2 = Sheets("[COLOR=#ff0000]New[/COLOR]")
   Set Dic = CreateObject("scripting.dictionary")
   
   For Each Cl In Ws1.Range("A2", Ws1.Range("A" & Rows.Count).End(xlUp))
      v1 = Cl.Value: v2 = Cl.Offset(, 1).Value
      If Cl.Offset(, 2).Value = "Remove" Then v3 = -Cl.Offset(, 3).Value Else v3 = Cl.Offset(, 3).Value
      If Not Dic.exists(v1) Then
         Dic.Add v1, CreateObject("scripting.dictionary")
         Dic(v1).Add v2, v3
      ElseIf Not Dic(v1).exists(v2) Then
         Dic(v1).Add v2, v3
      Else
         Dic(v1)(v2) = Dic(v1)(v2) + v3
      End If
   Next Cl
   For Each Ky1 In Dic.keys
      NxtRw = Ws2.Range("B" & Rows.Count).End(xlUp).Offset(1).Row
      Ws2.Range("A" & NxtRw).Value = Ky1
      Ws2.Range("B" & NxtRw + 1).Resize(Dic(Ky1).Count).Value = Application.Transpose(Dic(Ky1).keys)
      Ws2.Range("C" & NxtRw + 1).Resize(Dic(Ky1).Count).Value = Application.Transpose(Dic(Ky1).items)
   Next Ky1
   
End Sub
Change sheet names in red to suit
 
Upvote 0
Holy Smokes! That was amazingly fast. :) Thank you SO much!!! This is exactly what i was looking for, and it works perfectly!

BWL
 
Upvote 0
Glad to help & thanks for the feedback
 
Upvote 0

Forum statistics

Threads
1,213,495
Messages
6,113,992
Members
448,538
Latest member
alex78

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