How to consolidate row H & L and then sum value in column N & Q?
Screenshot of my data:
From the data populate to another sheet, I call it sheet "X".
Expected Result
I got this code from my last question, it uses a dictionary. It can only take 1 key and 1 value and does not meet my expectation:
Sub testttt()
Dim countDict As Object, countDict2 As Object
Set countDict = CreateObject("Scripting.Dictionary")
Set countDict2 = CreateObject("Scripting.Dictionary")
Dim x() As Variant
x = Sheets("Data").Range("A2").CurrentRegion.Value2
Dim a As Long
For a = 2 To UBound(x, 1)
countDict(x(a, 8)) = countDict(x(a, 8)) + x(a, 14)
countDict2(x(a, 12)) = countDict(x(a, 8))
Next
With ThisWorkbook.Sheets("X").Range("B5").Resize(countDict.Count)
.Offset(, 1).Value = Application.Transpose(countDict.Keys)
.Offset(, 4).Value = Application.Transpose(countDict2.Keys)
.Offset(, 5).Value = Application.Transpose(countDict.Items)
.Offset(, 6).Value = Application.Transpose(countDict2.Items)
End With
End Sub
build a key as a combination of the wanted values, and then use as many dictionaries as you need sharing the same key and having each a single value as item
Sub testttt()
Dim dictH As Object, dictSumQ As Object, dictSumN As Object, dictA As Object, dictI As Object, dictL As Object, dictR As Object
Set dictA = CreateObject("Scripting.Dictionary")
Set dictH = CreateObject("Scripting.Dictionary")
Set dictI = CreateObject("Scripting.Dictionary")
Set dictL = CreateObject("Scripting.Dictionary")
Set dictR = CreateObject("Scripting.Dictionary")
Set dictSumN = CreateObject("Scripting.Dictionary")
Set dictSumQ = CreateObject("Scripting.Dictionary")
Dim x() As Variant
x = Sheets("Data").Range("A2").CurrentRegion.Value2
Dim a As Long
Dim key As Variant
For a = 2 To UBound(x, 1)
key = x(a, 8) & "|" & x(a, 12) & "|"
dictA(key) = x(a, 1)
dictH(key) = x(a, 8)
dictI(key) = x(a, 9)
dictL(key) = x(a, 12)
dictR(key) = x(a, 18)
dictSumN(key) = dictSumN(key) + x(a, 14)
dictSumQ(key) = dictSumQ(key) + x(a, 17)
Next
With ThisWorkbook.Sheets("X1").Range("A5").Resize(dictSumN.Count)
.Offset(, 1).Value = Application.Transpose(dictA.Items)
.Offset(, 2).Value = Application.Transpose(dictH.Items)
.Offset(, 3).Value = Application.Transpose(dictI.Items)
.Offset(, 4).Value = Application.Transpose(dictR.Items)
.Offset(, 5).Value = Application.Transpose(dictL.Items)
.Offset(, 6).Value = Application.Transpose(dictSumN.Items)
.Offset(, 7).Value = Application.Transpose(dictSumQ.Items)
End With
End Sub
Related
Image1
Hi, Referring to the image, I am trying to compare column G and Column K, if the value is the same then copy the value in column J to column F. However, my code doesn't copy the value from Column J to F.
Sub createarray1()
Dim i As Integer
Dim j As Integer
Dim masterarray As Range
Set masterarray = Range("D3:G12")
Dim sourcearray As Range
Set sourcearray = Range("H3:K26")
For i = 1 To 10
For j = 1 To 25
If masterarray(i, 4).Value = sourcearray(j, 4).Value Then
masterarray(i, 3) = sourcearray(j, 3).Value
Else
masterarray(i, 3).Value = ""
End If
Next
Next
End Sub
Function concatenate()
Dim nlastrow As Long
For i = 2 To Cells(Rows.Count, "D").End(xlUp).Row
Cells(i, "G").Value = Cells(i, "D").Value & "_" & Cells(i, "E").Value
Next i
Dim nnlastrow As Long
For i = 2 To Cells(Rows.Count, "H").End(xlUp).Row
Cells(i, "K").Value = Cells(i, "H").Value & "_" & Cells(i, "I").Value
Next i
End Function
Use variant arrays, that way you limit the number of calls to the sheet to only 3.
When your positive is found you need to exit the inner loop.
Sub createarray1()
Dim i As Long
Dim j As Long
Dim masterarray As Variant
Dim sourcearray As Variant
With ThisWorkbook.Worksheets("Sheet1") ' change to your sheet
masterarray = .Range("D3:G12")
sourcearray = .Range("H3:K26")
For i = LBound(masterarray, 1) To UBound(masterarray, 1)
masterarray(i, 3) = ""
For j = LBound(sourcearray, 1) To UBound(sourcearray, 1)
If masterarray(i, 4) = sourcearray(j, 4) Then
masterarray(i, 3) = sourcearray(j, 3)
Exit For
End If
Next j
Next i
.Range("D3:G12") = masterarray
End With
End Sub
But this can all be done with the following formula:
=INDEX(J:J,MATCH(G3,K:K,0))
Put it in F3 and copy/drag down.
I am completely stumped on this problem here. I created a macro that will read values from the current spreadsheet, place those values into a dictionary using row numbers as keys, create a new spreadsheet, grab the values from those dictionaries, and add them to the new spreadsheet. There are three dictionaries that are filled. I have no problem getting the values from two of the dictionaries and I even have no problems getting the first couple of values from the problematic dictionaries. But when I try to retrieve the last two values in the last For Next loop, the values are read as "" instead of an actual value. The image below is a message that I built from looping the problematic dictionary.
I had the debug loop that produced this message within the last For Next loop. As you can see each key has a value, but when I use dataN.Exist(key) for just the last two values I get "" as the value. I don't understand. The exact same code works to pull the first couple of values but not the last couple. I have even moved those values to different rows but still got the same "". Here is the entire code here below:
Sub Transfer2NewWorkbook()
Dim currentsheet As String
Dim newsheet As String
Dim analysisDate As String
Dim initial As String
Dim aInitial() As String
Dim analystInit As String
Dim aBatch() As String
Dim batch As String
Dim batchNo As String
Dim key As Variant
Dim ikey As Variant
Dim SrowN As String
Dim rowN As Integer
Dim rowD As String
Dim wb As Object
Dim dataRangeN As Range, dataRangeB As Range, dataRangeI As Range
Dim dataN As Object
Set dataN = CreateObject("Scripting.Dictionary")
Dim dataB As Object
Set dataB = CreateObject("Scripting.Dictionary")
Dim dataI As Object
Set dataI = CreateObject("Scripting.Dictionary")
Dim teststring As String
' Grab and Create filenames
currentsheet = ActiveWorkbook.Name
newsheet = currentsheet & "-" & "uploadable"
' Grab data from original spreadsheet
analysisDate = ActiveWorkbook.Sheets(1).Cells(1, 9).Value
initial = ActiveWorkbook.Sheets(1).Cells(1, 2).Value
aInitial = Split(initial, "/")
analystInit = aInitial(1)
batch = ActiveWorkbook.Sheets(1).Cells(1, 4).Value
aBatch = Split(batch, ":")
batchNo = aBatch(1)
Set dataRangeN = Range("A:A")
Set dataRangeB = Range("B:B")
Set dataRangeI = Range("I:I")
For i = 4 To dataRangeB.Rows.Count
If Not IsEmpty(dataRangeB(i, 1)) Then
If StrComp(ActiveWorkbook.Sheets(1).Cells(i, 2).Value, "End") = 0 Then
Exit For
ElseIf StrComp(ActiveWorkbook.Sheets(1).Cells(i, 2).Value, "Blank") = 0 Then
If StrComp(ActiveWorkbook.Sheets(1).Cells(i, 1).Value, "Unseeded") = 0 Or StrComp(ActiveWorkbook.Sheets(1).Cells(i, 1).Value, "Seeded") = 0 Then
If Not IsEmpty(dataRangeI(i, 1)) Then
dataN.Add i, ActiveWorkbook.Sheets(1).Cells(i, 1).Value
dataB.Add i, ActiveWorkbook.Sheets(1).Cells(i, 2).Value
dataI.Add i, ActiveWorkbook.Sheets(1).Cells(i, 9).Value
End If
End If
ElseIf StrComp(ActiveWorkbook.Sheets(1).Cells(i, 2).Value, "Check") = 0 Then
If StrComp(ActiveWorkbook.Sheets(1).Cells(i, 1).Value, "Std") = 0 Then
If Not IsEmpty(dataRangeI(i, 1)) Then
dataN.Add i, ActiveWorkbook.Sheets(1).Cells(i, 1).Value
dataB.Add i, ActiveWorkbook.Sheets(1).Cells(i, 2).Value
dataI.Add i, ActiveWorkbook.Sheets(1).Cells(i, 9).Value
End If
End If
ElseIf StrComp(ActiveWorkbook.Sheets(1).Cells(i, 2).Value, "DUP") = 0 Then
rowD = dataB.Keys()(dataB.Count - 1)
If StrComp(ActiveWorkbook.Sheets(1).Cells(i - 1, 1).Value, "CBOD") = 0 Then
dataN.Add rowD, "DUP-CBOD"
ElseIf StrComp(ActiveWorkbook.Sheets(1).Cells(i - 1, 1).Value, "BOD") = 0 Then
dataN.Add rowD, "DUP-BOD"
End If
Else
dataB.Add i, ActiveWorkbook.Sheets(1).Cells(i, 2).Value
dataI.Add i, ActiveWorkbook.Sheets(1).Cells(i, 9).Value
End If
Else
If StrComp(ActiveWorkbook.Sheets(1).Cells(i, 1).Value, "DUP") = 0 Then
rowD = dataB.Keys()(dataB.Count - 1)
If StrComp(ActiveWorkbook.Sheets(1).Cells(i - 1, 1).Value, "CBOD") = 0 Then
dataN.Add rowD, "DUP-CBOD"
ElseIf StrComp(ActiveWorkbook.Sheets(1).Cells(i - 1, 1).Value, "BOD") = 0 Then
dataN.Add rowD, "DUP-BOD"
End If
End If
End If
Next i
' Open new spreadsheet
Set wb = Workbooks.Add("C:\Users\dalythe\documents\uploadtemp.xlsx")
ActiveWorkbook.Sheets(1).Cells(2, 2).Value = analysisDate
ActiveWorkbook.Sheets(1).Cells(2, 4).Value = analystInit
ActiveWorkbook.Sheets(1).Cells(3, 5).Value = batchNo
rowN = 4
For Each key In dataB.Keys
If dataI.Exists(key) Then
SrowN = CStr(rowN)
If dataN.Exists(key) Then
ActiveWorkbook.Sheets(1).Cells(SrowN, 1).Value = dataN(key)
End If
ActiveWorkbook.Sheets(1).Cells(SrowN, 2).Value = dataB(key)
ActiveWorkbook.Sheets(1).Cells(SrowN, 3).Value = dataI(key)
rowN = CInt(SrowN)
rowN = rowN + 1
End If
Next
ActiveWorkbook.SaveAs (newsheet & ".xlsx")
End Sub
I am working on my computer to automate a quote in Excel with VBA
It consists of finding duplicates so they can be summed.
For example:
I have the following information:
Click here for the Excel file
The range from A2:C4 is a group that it states there are 28 bolts, 1 nut for each bolt & 1 washer for each bolt.
A5:C7 is another group that is the same 28 bolts, 1 nut for each bolt & 1 washer for each bolt.
A11:C13 is another group but the difference is that for this one are 2 nuts & 2 washer per bolt.
So this wont be sum
This would be the result:
I have the following code where it only looks through all the cells, I can't find a way to make it look in groups or ranges.
Sub Macro1()
Dim LastRow As Long, LastColumn As Long
Dim wSrc As Worksheet: Set wSrc = Sheets("Hoja1")
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
With wSrc
LastRow = .Range("B" & .Rows.Count).End(xlUp).Row
Set rng = .Range("B1:B" & LastRow)
LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column + 2
rng.AdvancedFilter Action:=xlFilterCopy, copytoRange:=.Cells(1, LastColumn), unique:=True
Z = .Cells(.Rows.Count, LastColumn).End(xlUp).Row
LastColumn = LastColumn + 1
.Cells(1, LastColumn).Value = "Total"
.Range(.Cells(2, LastColumn), .Cells(Z, LastColumn)).Formula = _
"=SUMIF(" & rng.Address & "," & .Cells(2, LastColumn - 1).Address(False, False) & "," & rng.Offset(, 1).Address & ")"
End With
With Application
.ScreenUpdating = Truek
.Calculation = xlCalculationAutomatic
End With
End Sub
Click below for the Excel file
Here is an approach that utilizes User Defined Object for the Hardware, and Hardware groups.
We could create more compact code with fewer loops, but, unless there is a significant speed issue, this is probably more readable, and can be more easily adapted to future needs.
We create two class modules (and be sure to rename them as indicated in the code).
One class module is for the hardware items, the second is for the different groups.
The hardware items properties are the description, the weight per item, and the number of items.
The hardware groups properties are a collection of Hardware items, and the Quantity of items in that group.
We then combine the hardware groups into a collection of unique hardware groups.
As the code is written, you could combine in other ways to generate other types of reports.
The results:
Class Module 1
'**Rename: cHardware**
Option Explicit
Private pDescription As String
Private pWt As Double
Private pItemCount As Long
Public Property Get Description() As String
Description = pDescription
End Property
Public Property Let Description(Value As String)
pDescription = Value
End Property
Public Property Get Wt() As Double
Wt = pWt
End Property
Public Property Let Wt(Value As Double)
pWt = Value
End Property
Public Property Get ItemCount() As Long
ItemCount = pItemCount
End Property
Public Property Let ItemCount(Value As Long)
pItemCount = Value
End Property
Class Module 2
'**Rename: cHardwareGrp**
Option Explicit
Private pHW As cHardWare
Private pHWs As Collection
Private pQty As Long
Private Sub Class_Initialize()
Set pHWs = New Collection
End Sub
Public Property Get HW() As cHardWare
Set HW = pHW
End Property
Public Property Let HW(Value As cHardWare)
Set pHW = Value
End Property
Public Property Get HWs() As Collection
Set HWs = pHWs
End Property
Public Function AddHW(Value As cHardWare)
Dim I As Long, J As Long
If pHWs.Count = 0 Then
pHWs.Add Value
Else 'Insert in sorted order
For J = pHWs.Count To 1 Step -1
If pHWs(J).Description <= Value.Description Then Exit For
Next J
If J = 0 Then
pHWs.Add Value, before:=1
Else
pHWs.Add Value, after:=J
End If
End If
End Function
Public Property Get Qty() As Long
Qty = pQty
End Property
Public Property Let Qty(Value As Long)
pQty = Value
End Property
Regular Module
Option Explicit
Sub SummarizeHW()
Dim wsRes As Worksheet, wsSrc As Worksheet, rRes As Range
Dim vSrc As Variant, vRes() As Variant
Dim cHW As cHardWare, colHW As Collection
Dim cHWG As cHardwareGrp, colHWG As Collection
Dim colUniqueHWG As Collection
Dim I As Long, J As Long, K As Long
Dim lQTY As Long
Dim S As String
Dim V As Variant
Dim RE As Object, MC As Object
'Set Source and Results Worksheets and Ranges
Set wsSrc = Worksheets("Hoja1")
Set wsRes = Worksheets("Hoja2")
Set rRes = wsRes.Cells(1, 1)
'Get Source Data
With wsSrc
vSrc = .Range(.Cells(1, 2), .Cells(.Rows.Count, 2).End(xlUp)) _
.Offset(columnoffset:=-1).Resize(columnsize:=3)
End With
'Set up regex to extract number of HW items in description
Set RE = CreateObject("vbscript.regexp")
With RE
.Global = False
.Pattern = "^\((\d+)\)\s*"
.MultiLine = True
End With
'Collect unique list of hardware items
' compute the weight of each single item
Set colHW = New Collection
On Error Resume Next
For I = 2 To UBound(vSrc, 1) 'assumes header row
If vSrc(I, 1) <> "" Then lQTY = vSrc(I, 1)
Set cHW = New cHardWare
With cHW
S = vSrc(I, 2)
If RE.test(S) = True Then
Set MC = RE.Execute(S)
.ItemCount = CLng(MC(0).submatches(0))
Else
.ItemCount = 1
End If
.Wt = vSrc(I, 3) / lQTY / .ItemCount
.Description = S
colHW.Add cHW, .Description
End With
Next I
On Error GoTo 0
'Collect the Hardware Groups
'HW group starts if there is a "Qty" in column 1
Set colHWG = New Collection
For I = 2 To UBound(vSrc, 1)
If vSrc(I, 1) <> "" Then lQTY = vSrc(I, 1)
Set cHWG = New cHardwareGrp
Do
With cHWG
.HW = colHW(vSrc(I, 2))
.AddHW .HW
.Qty = lQTY
End With
I = I + 1
If I > UBound(vSrc, 1) Then Exit Do
Loop Until vSrc(I, 1) <> ""
colHWG.Add cHWG
I = I - 1
Next I
'Collect the unique hardware groups
' A group is defined by ALL of the hardware components being identical
' in both type and quantity. Therefore, we can concatenate them as a key
Set colUniqueHWG = New Collection
On Error Resume Next
For I = 1 To colHWG.Count
With colHWG(I)
ReDim V(1 To .HWs.Count)
For J = 1 To UBound(V)
V(J) = .HWs(J).Description
Next J
S = Join(V, "|")
colUniqueHWG.Add colHWG(I), S
Select Case Err.Number
Case 457 'a duplicate so add the QTY
colUniqueHWG(S).Qty = colUniqueHWG(S).Qty + .Qty
Err.Clear
Case Is <> 0 'error stop
Debug.Print Err.Number, Err.Description
End Select
End With
Next I
On Error GoTo 0
'Final Report
'# of columns = 3
'# of rows = sum of the number of HW items in each group + 1 for the header
J = 0
For I = 1 To colUniqueHWG.Count
J = J + colUniqueHWG(I).HWs.Count
Next I
ReDim vRes(0 To J, 1 To 3)
'Column headers
vRes(0, 1) = "Qty"
vRes(0, 2) = "Hardware Description"
vRes(0, 3) = "Weight"
'populate the results array'
K = 1
For I = 1 To colUniqueHWG.Count
With colUniqueHWG(I)
For J = 1 To .HWs.Count
If J = 1 Then vRes(K, 1) = .Qty
vRes(K, 2) = .HWs(J).Description
vRes(K, 3) = .Qty * .HWs(J).Wt * .HWs(J).ItemCount
K = K + 1
Next J
End With
Next I
'Write the results on a new sheet
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
.EntireColumn.Clear
.Value = vRes
.ColumnWidth = 255
With Rows(1)
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
.EntireColumn.AutoFit
End With
End Sub
Hmmm. I see from your comments that the hardware may not always be in the same order. I will add a sorting routine to our group generation so that will be irrelevant.
EDIT: The AddHW function was modified to insert the HW items in sorted order. Since there should only be a few items, this insertion sort should be adequate.
Taking a different approach.
take advantage of the structure; three lines define it
Put results on a different tab
This input ...
generates this output ...
using this code ...
Option Explicit
Sub Macro1()
Dim LastRow As Long, LastColumn As Long
Dim wSrc As Worksheet: Set wSrc = Sheets("Hoja1")
Dim tmpSrc As Worksheet
Dim outRng As Range, inRng As Range
Dim iLoop As Long, jLoop As Long, QSum As Long
' turn off updating for speed
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
' setup - tmpSrc is the working and final result
Set tmpSrc = ActiveWorkbook.Sheets.Add(, wSrc)
Set inRng = wSrc.UsedRange
inRng.Copy
tmpSrc.Range("A1").PasteSpecial (xlPasteAll)
With tmpSrc
.Name = "Hoja2"
Set outRng = .UsedRange
LastRow = .UsedRange.Rows.Count
LastColumn = .UsedRange.Columns.Count
End With
' loop down through the range
For iLoop = 2 To LastRow
If outRng.Cells(iLoop, 1) <> "" Then
QSum = outRng.Cells(iLoop, 1).Value
For jLoop = LastRow To iLoop + 1 Step -1 'loop up through the range to find a match
' matches are defined by all three rows in column B
If outRng.Cells(jLoop, 1) <> "" And _
outRng.Cells(iLoop, 2) = outRng.Cells(jLoop, 2) And _
outRng.Cells(iLoop + 1, 2) = outRng.Cells(jLoop + 1, 2) And _
outRng.Cells(iLoop + 2, 2) = outRng.Cells(jLoop + 2, 2) Then
QSum = QSum + outRng.Cells(jLoop, 1).Value
outRng.Rows(jLoop + 2).Delete
outRng.Rows(jLoop + 1).Delete
outRng.Rows(jLoop).Delete
LastRow = LastRow - 3
End If
Next jLoop
outRng.Cells(iLoop, 1).Value = QSum
End If
Next iLoop
For iLoop = 1 To 3
outRng.Columns(iLoop).ColumnWidth = inRng.Columns(iLoop).ColumnWidth
Next iLoop
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Edit:
Summing weights for bolts, nuts, and washers
Checking for case where nuts and washers appear in reverse order
n.b. I am using .UsedRange to find the last row and last column. Other methods are available.
.
Option Explicit
Sub Macro1()
Dim LastRow As Long, LastColumn As Long
Dim wSrc As Worksheet: Set wSrc = Sheets("Hoja1")
Dim tmpSrc As Worksheet
Dim outRng As Range, inRng As Range
Dim iLoop As Long, jLoop As Long, QSum As Long
Dim WSum1 As Double, WSum2 As Double, WSum3 As Double
' turn off updating for speed
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
' setup - tmpSrc is the working and final result
Set tmpSrc = ActiveWorkbook.Sheets.Add(, wSrc)
Set inRng = wSrc.UsedRange
inRng.Copy
tmpSrc.Range("A1").PasteSpecial (xlPasteAll)
With tmpSrc
.Name = "Hoja2"
Set outRng = .UsedRange
LastRow = .UsedRange.Rows.Count
LastColumn = .UsedRange.Columns.Count
End With
' loop down through the range
For iLoop = 2 To LastRow
If outRng.Cells(iLoop, 1) <> "" Then
QSum = outRng.Cells(iLoop, 1).Value
WSum1 = outRng.Cells(iLoop, 3).Value
WSum2 = outRng.Cells(iLoop + 1, 3).Value
WSum3 = outRng.Cells(iLoop + 2, 3).Value
For jLoop = LastRow To iLoop + 1 Step -1 'loop up through the range to find a match
' matches are defined by all three rows in column B
If outRng.Cells(jLoop, 1) <> "" And _
outRng.Cells(iLoop, 2) = outRng.Cells(jLoop, 2) And _
outRng.Cells(iLoop + 1, 2) = outRng.Cells(jLoop + 1, 2) And _
outRng.Cells(iLoop + 2, 2) = outRng.Cells(jLoop + 2, 2) Then
QSum = QSum + outRng.Cells(jLoop, 1).Value
WSum1 = WSum1 + outRng.Cells(jLoop, 3).Value
WSum2 = WSum2 + outRng.Cells(jLoop + 1, 3).Value
WSum3 = WSum3 + outRng.Cells(jLoop + 2, 3).Value
outRng.Rows(jLoop + 2).Delete
outRng.Rows(jLoop + 1).Delete
outRng.Rows(jLoop).Delete
LastRow = LastRow - 3
Else ' check if bolts and washers are in reverse order
If outRng.Cells(jLoop, 1) <> "" And _
outRng.Cells(iLoop, 2) = outRng.Cells(jLoop, 2) And _
outRng.Cells(iLoop + 1, 2) = outRng.Cells(jLoop + 2, 2) And _
outRng.Cells(iLoop + 2, 2) = outRng.Cells(jLoop + 1, 2) Then
QSum = QSum + outRng.Cells(jLoop, 1).Value
WSum1 = WSum1 + outRng.Cells(jLoop, 3).Value
WSum2 = WSum2 + outRng.Cells(jLoop + 2, 3).Value
WSum3 = WSum3 + outRng.Cells(jLoop + 1, 3).Value
outRng.Rows(jLoop + 2).Delete
outRng.Rows(jLoop + 1).Delete
outRng.Rows(jLoop).Delete
LastRow = LastRow - 3
End If
End If
Next jLoop
outRng.Cells(iLoop, 1).Value = QSum
outRng.Cells(iLoop, 3).Value = WSum1
outRng.Cells(iLoop + 1, 3).Value = WSum2
outRng.Cells(iLoop + 2, 3).Value = WSum3
End If
Next iLoop
For iLoop = 1 To 3
outRng.Columns(iLoop).ColumnWidth = inRng.Columns(iLoop).ColumnWidth
Next iLoop
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
I am adapting off of the question: Re-Arranging the row data in columns
I have Excel data set up as follows;
Collection LatDD LonDD Date Location Method Specie1 Specie2 Specie3(+-110 species columns in total)
ABS1 11.35 -10.3 2003-02-01 A Bucket 0 1 3
ABS2 11.36 -10.4 2003-02-02 B Stick 2 0 6
I would Like This Data to appear like so:
Collection Specie Count LatDD LonDD Date Location Method
ABS1 Specie1 11.35 -10.3 2003-02-01 A Bucket
ABS1 Specie2 1 11.35 -10.3 2003-02-01 A Bucket
ABS1 Specie3 3 11.35 -10.3 2003-02-01 A Bucket
ABS2 Specie1 2 11.36 -10.4 2003-02-02 B Stick
ABS2 Specie2 -11.36 -10.4 2003-02-02 B Stick
ABS2 Specie3 6 -11.36 -10.4 2003-02-02 B Stick
I attempted to adapt Ripsters original VBA code answer but unfortunately i was unable to figure how i would need to change it. Could someone please advise me on how to adjust his code to produce the desired output?
Here is his orginal vba code:
Sub Example()
Dim Resources() As String
Dim rng As Range
Dim row As Long
Dim col As Long
Dim x As Long
ReDim Resources(1 To (ActiveSheet.UsedRange.Rows.Count - 1) * (ActiveSheet.UsedRange.Columns.Count - 1), 1 To 3)
'Change this to the source sheet
Sheets("Sheet1").Select
'Read data into an array
For row = 2 To ActiveSheet.UsedRange.Rows.Count
For col = 2 To ActiveSheet.UsedRange.Columns.Count
x = x + 1
Resources(x, 1) = Cells(row, 1).Value ' Get name
Resources(x, 2) = Cells(1, col).Value ' Get date
Resources(x, 3) = Cells(row, col).Value ' Get value
Next
Next
'Change this to the destination sheet
Sheets("Sheet2").Select
'Write data to sheet
Range(Cells(1, 1), Cells(UBound(Resources), UBound(Resources, 2))).Value = Resources
'Insert column headers
Rows(1).Insert
Range("A1:C1").Value = Array("Resource", "Date", "Value")
'Set strings to values
Set rng = Range(Cells(1, 3), Cells(ActiveSheet.UsedRange.Rows.Count, 3))
rng.Value = rng.Value
End Sub
Try this:
Sub Example()
Dim row As Long
Dim col As Long
Dim x As Long
h1 = "Sheet1"
h2 = "Sheet2"
Sheets(h1).Select
x = 2
'Headers Sheet2
Sheets(h2).Cells(1, 1).Value = Sheets(h1).Cells(1, 1)
Sheets(h2).Cells(1, 2).Value = "Specie"
Sheets(h2).Cells(1, 3).Value = "Count"
Sheets(h2).Cells(1, 4).Value = Sheets(h1).Cells(1, 2)
Sheets(h2).Cells(1, 5).Value = Sheets(h1).Cells(1, 3)
Sheets(h2).Cells(1, 6).Value = Sheets(h1).Cells(1, 4)
Sheets(h2).Cells(1, 7).Value = Sheets(h1).Cells(1, 5)
Sheets(h2).Cells(1, 8).Value = Sheets(h1).Cells(1, 6)
For row = 2 To ActiveSheet.UsedRange.Rows.Count
For col = 7 To ActiveSheet.UsedRange.Columns.Count
Sheets(h2).Cells(x, 1).Value = Sheets(h1).Cells(row, 1).Value
Sheets(h2).Cells(x, 2).Value = Sheets(h1).Cells(1, col).Value
Sheets(h2).Cells(x, 3).Value = Sheets(h1).Cells(row, col).Value
Sheets(h2).Cells(x, 4).Value = Sheets(h1).Cells(row, 2).Value
Sheets(h2).Cells(x, 5).Value = Sheets(h1).Cells(row, 3).Value
Sheets(h2).Cells(x, 6).Value = Sheets(h1).Cells(row, 4).Value
Sheets(h2).Cells(x, 7).Value = Sheets(h1).Cells(row, 5).Value
Sheets(h2).Cells(x, 8).Value = Sheets(h1).Cells(row, 6).Value
x = x + 1
Next
Next
End Sub
Sheet1:
Sheet2:
A short versión:
Sub Example()
Dim row As Long
Dim col As Long
Dim x As Long
Set Sh1 = ThisWorkbook.Worksheets("Sheet1")
Set Sh2 = ThisWorkbook.Worksheets("Sheet2")
Sh1.Select
'Headers Sheet2
Sh2.Cells(1, 1).Value = Sh1.Cells(1, 1)
Sh2.Cells(1, 2).Value = "Specie"
Sh2.Cells(1, 3).Value = "Count"
For i = 4 To 8
Sh2.Cells(1, i).Value = Sh1.Cells(1, i - 2)
Next
x = 2 'Starting row of sheet2.
For row = 2 To ActiveSheet.UsedRange.Rows.Count
For col = 7 To ActiveSheet.UsedRange.Columns.Count
Sh2.Cells(x, 1).Value = Sh1.Cells(row, 1).Value
Sh2.Cells(x, 2).Value = Sh1.Cells(1, col).Value
Sh2.Cells(x, 3).Value = Sh1.Cells(row, col).Value
For i = 4 To 8
Sh2.Cells(x, i).Value = Sh1.Cells(row, i - 2).Value
Next
x = x + 1
Next
Next
Sh2.Select
End Sub
another idea....
Your source data is in "Sheet1", starting at "A1", no empty values neither in Column A, nor in Row 1.
If you run the code, you will get the re-sorted table in "Sheet2" ( I omitted headers, though - too lazy....)
Hope this helps
Sub sort_new()
Dim col_no As Long, row_no As Long
Dim i As Long, j As Long, k As Long
Dim arr_DB As Variant, arr_new As Variant
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
ws1.Activate
row_no = ws1.Range(Cells(Rows.Count, 1), Cells(Rows.Count, 1)).End(xlUp).Row
col_no = ws1.Range(Cells(1, Columns.Count), Cells(1, Columns.Count)).End(xlToLeft).Column
arr_DB = ws1.Range(Cells(1, 1), Cells(row_no, col_no))
ReDim arr_new(1 To (row_no - 1) * (col_no - 6), 1 To 8)
For i = 2 To row_no
For j = 7 To col_no
k = k + 1
arr_new(k, 1) = arr_DB(i, 1) 'Collection
arr_new(k, 4) = arr_DB(i, 2) 'LatDD
arr_new(k, 5) = arr_DB(i, 3) 'LonDD
arr_new(k, 6) = arr_DB(i, 4) 'Date
arr_new(k, 7) = arr_DB(i, 5) 'Location
arr_new(k, 8) = arr_DB(i, 6) 'Method
arr_new(k, 2) = arr_DB(1, j) 'Each Specie(j) Column
arr_new(k, 3) = arr_DB(i, j) 'Each Specie(j) Column
Next
Next
ws2.Activate
ws2.Range(Cells(2, 1), Cells((row_no - 1) * (col_no - 6) + 1, 8)) = arr_new
End Sub
I created a macro in Excel to mergue duplicated rows:
The idea is that if 2 rows or more have the same A B C columns, I mergue their D columns removing ABC duplicates.
I need to do this, but checking more colums.
My macro looks like this:
processingRow = 2
Do Until Cells(processingRow, 1).Value = ""
i = processingRow + 1
Do Until Cells(i, 1).Value = ""
If Cells(processingRow, 8) = Cells(i, 8) And _
Cells(processingRow, 12) = Cells(i, 12) And _
Cells(processingRow, 7) = Cells(i, 7) And _
Cells(processingRow, 6) = Cells(i, 6) And _
Cells(processingRow, 5) = Cells(i, 5) And _
Cells(processingRow, 4) = Cells(i, 4) And _
Cells(processingRow, 3) = Cells(i, 3) And _
Cells(processingRow, 2) = Cells(i, 2) And _
Cells(processingRow, 1) = Cells(i, 1) Then
If Cells(i, 14) <> "" Then
Cells(processingRow, 14) = Cells(processingRow, 14) & "," & Cells(i, 14)
End If
Rows(i).Delete
End If
i = i + 1
Loop
processingRow = processingRow + 1
Loop
When running the macro with 500 rows, it takes a while, but its still reasonable. But I need to run this macro in a excel with more than 2500 rows, and it takes so much time that its not practical anymore.
This is my first macro in excel using VBA, so I was wondering if there is a faster way to process rows/cells, since accessing them individually seems extremelly slow.
Any ideas?
EDITED: I missed that you weren't checking every column to determine what was a duplicate. This should be closer now:
Sub Tester()
Dim rngCheck As Range, rw As Range
Dim dict As Object, k As String, rwDup As Range
Dim rngDel As Range, tmp
Set dict = CreateObject("scripting.dictionary")
With ActiveSheet
Set rngCheck = .Range(.Cells(2, 1), _
.Cells(Rows.Count, 1).End(xlUp)).Resize(, 14)
End With
For Each rw In rngCheck.Rows
k = RowKey(rw)
If dict.exists(k) Then
Set rwDup = dict(k)
tmp = rw.Cells(14).Value
If Len(tmp) > 0 Then
rwDup.Cells(14).Value = rwDup.Cells(14).Value & "," & tmp
End If
If rngDel Is Nothing Then
Set rngDel = rw
Else
Set rngDel = Application.Union(rngDel, rw)
End If
Else
dict.Add k, rw
End If
Next rw
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete
End Sub
'create a "key" for the row by joining all columns to be checked
Function RowKey(rw As Range) As String
Dim arr, x As Long, sep As String, rv As String
arr = Array(1, 2, 3, 4, 5, 6, 7, 8, 12)
For x = LBound(arr) To UBound(arr)
rv = rv & sep & rw.Cells(arr(x)).Value
sep = Chr(0)
Next x
RowKey = rv
End Function