I have a For loop to look at columns and need to skip two columns. When I run this code, the second For loop (with iCol) does not work.
The code within the loop works fine when I tested outside of the loop. I have tried different options to exclude the two columns from the For loop (select case) but nothing works.
Dim rng As Range
Dim n As Long
Dim iRow As Long
Dim iCol As Long
Dim NameColNum As Integer
Dim LNameColNum As Integer
Dim DoBColNum As Integer
Dim SColNum As Integer
Dim JColNum As Integer
' Sets data range
Set rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
NameColNum = Application.Match("First Name", rng.EntireRow(1), 0)
LNameColNum = Application.Match("Last Name", rng.EntireRow(1), 0)
DoBColNum = Application.Match("Birth Date", rng.EntireRow(1), 0)
' For S and J cases
SColNum = Application.Match("Created User ID", rng.EntireRow(1), 0)
JColNum = Application.Match("W Name", rng.EntireRow(1), 0)
For iRow = 2 To rng.Rows.Count
If rng.Cells(iRow, NameColNum) = rng.Cells(iRow + 1, NameColNum) And _
rng.Cells(iRow, LNameColNum) = rng.Cells(iRow + 1, LNameColNum) And _
rng.Cells(iRow, DoBColNum) = rng.Cells(iRow + 1, DoBColNum) Then
If rng.Cells(iRow, SColNum).Value = "STAGE" Then
rng.EntireRow(iRow).Interior.ColorIndex = 3
rng.EntireRow(iRow + 1).Interior.ColorIndex = 3
End If
If rng.Cells(iRow, JColNum) = "Smith" Then
rng.EntireRow(iRow).Interior.ColorIndex = 4
rng.EntireRow(iRow + 1).Interior.ColorIndex = 4
End If
For iCol = DoBColNum + 1 To rng.Columns.Count
If iCol <> SColNum And iCol <> JColNum Then
If rng.Cells(iRow, iCol).Value <> rng.Cells(iRow + 1, iCol).Value And _
rng.EntireRow(iRow).Interior.ColorIndex = -4142 Then
rng.EntireRow(iRow).Interior.ColorIndex = iCol
rng.EntireRow(iRow + 1).Interior.ColorIndex = iCol
End If
End If
Next 'iCol
End If
Next 'iRow
rng.Columns.Count is always going to equal 1, because you limited rng to column A on your Set line. Because of this, your second loop will never run (You're trying to loop 4 to 1, etc.).
Instead, change Set rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp)) to include all columns that your working with, and get the last row value from column A on another line.
Suggested fix:
Dim lastrow As Long
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
' Sets data range
Set rng = Range(Range("A1"), Range("S" & lastrow))
Related
What I need help on is to copy the previous cells text into the cell below it and add the letter A at the end of it i.e. before VP0007 after VP0007A. This should continue until all the blank cells have been incremented and it reaches the next VP0008.
Please see the images. I apologise if I am not too clear.
Before: After:
Right now I have the following code:
ActiveCell.Offset(1, 0).Select
Letter = "A"
Letters = Chr(Asc(Letter) + 1)
Number = ActiveCell.Offset(-1, 0).Value
If ActiveCell.Value = Number & Letter _ Then
ActiveCell.Offset(1, 0).Select.Value Number & Number
Else
ActiveCell.Value = Number & Letters
End If
Loop Until ActiveCell.Offset(1, 0).Value <> ""
Try this short sub procedure.
Sub fillSubseries()
Dim i As Long, a As Long, str As String
With Worksheets("sheet4")
For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
If IsEmpty(.Cells(i, "A")) Then
.Cells(i, "A") = str & Chr(a)
a = a + 1
Else
a = 65
str = .Cells(i, "A").Value2
End If
Next i
End With
End Sub
Try using the below code
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
Letter = "A"
For iLoop = 2 To LastRow
If ActiveSheet.Range("A" & iLoop) = "" Then
iValue = ActiveSheet.Range("A" & iLoop - 1)
iiLoop = iLoop
Do
If ActiveSheet.Range("A" & iiLoop) = "" Then
ActiveSheet.Range("A" & iiLoop) = iValue & Letter
Letter = Chr(Asc(Letter) + 1)
Else
Letter = "A"
Exit Do
End If
iiLoop = iiLoop + 1
Loop
iLoop = iiLoop - 1
End If
Next
This code should handle cases where you have more than 26 blank rows and increment past the letter "Z".
Sub FillBlanks()
Dim lastRow As Long, cnt As Long, i As Long
Dim prevItem As String
Dim ws As Worksheet
Set ws = ActiveSheet
lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
prevItem = ws.Cells(2, 1).Value
cnt = 0
For i = 2 To lastRow
If ws.Cells(i, 1) = "" Then
cnt = cnt + 1
ws.Cells(i, 1).Value = prevItem & Split(Cells(1, cnt).Address(True, False), "$")(0)
Else
prevItem = ws.Cells(i, 1)
cnt = 0
End If
Next i
End Sub
Alternate:
Sub tgr()
Dim ws As Worksheet
Dim aData As Variant
Dim sTemp As String
Dim sLetter As String
Dim i As Long, j As Long
Set ws = ActiveWorkbook.ActiveSheet
With ws.Range("A2", ws.Cells(ws.Rows.Count, "A").End(xlUp))
If .Row < 2 Then Exit Sub 'No data
aData = .Value
End With
For i = LBound(aData, 1) To UBound(aData, 1)
If Len(Trim(aData(i, 1))) > 0 Then
sTemp = Trim(aData(i, 1))
j = 0
Else
j = j + 1
sLetter = Replace(ws.Cells(1, j).Address(0, 0), 1, vbNullString)
aData(i, 1) = sTemp & sLetter
End If
Next i
ws.Range("A2").Resize(UBound(aData, 1)).Value = aData
End Sub
If you need a pure formula solution, you may try below steps (The first row of your data should be A2, not A1):
First we need a dummy column in order to fill in the blank rows. Use below formula on B2 and copy it down through the last row of column A:
=IF(A2<>"",A2,B1)
Then we will create the final values on column C. Add below formula to C2 and copy down:
=IF(A2<>"",A2,IF(ISNUMBER(VALUE(RIGHT(C1,1)))=TRUE,C1&"A",B2&CHAR(CODE(RIGHT(C1,1))+1)))
Basically we first filled in the blank rows with repeating values on column B. Then copied Col:A value to Col:C if Col:A is not blank. If Col:A is blank and upper row (Col:C) value's last character is numeric we add "A" to that value. If the last character is a letter than we concatenate the next letter with Col:B value.
You should have something like below, when everything is OK:
I need help.
In a sheet I need concatenate with a loop the columns "a" + "b" + "c", next the columns "d" + "e" + "f", etc ... an go up to the last column.
My script is locked to the second loop...
The concatenated results are to appear in a second sheet.
this is my incorrect code:
Sub concatena()
Dim x As String
Dim Y As String
b = 1 'colonna selezionata
For c = 1 To 5 'colonne concatenate da riportare
For q = 1 To 10 'righe su cui effettuare l'operazione
For t = 1 To 3 'numero celle da concatenare
For Each cell In Worksheets(1).Cells(q, t)
If cell.Value = "" Then GoTo Line1
x = x & cell(1, b).Value & "" & ""
Next
Next t
Line1:
On Error GoTo Terminate
Worksheets(2).Cells(q, c).Value = Mid(x, 1, Len(x))
x = "" 'mantiene la formattazione
Next q
b = 3 + 1 ' sposta il concatena di 3 celle la selezione delle colonne
Next c
Terminate: 'error handler
End Sub
Thank you all for the help!
This one uses arrays to speed it up a little:
Sub concatena()
Dim inArr() As Variant
Dim oArr() As Variant
Dim i&, j&
Dim ws As Worksheet
Dim rng As Range
Set ws = Worksheets("Sheet9") ' change to your worksheet
With ws
Set rng = .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, .Cells(1, .Columns.Count).End(xlToLeft).Column))
inArr = rng.Value
ReDim oArr(1 To UBound(inArr, 1), 1 To UBound(inArr, 2) / 3)
For i = LBound(inArr, 1) To UBound(inArr, 1)
For j = LBound(inArr, 2) To UBound(inArr, 2) Step 3
oArr(i, Int((j - 1) / 3) + 1) = inArr(i, j) & inArr(i, j + 1) & inArr(i, j + 2)
Next j
Next i
rng.Clear
.Range("A1").Resize(UBound(oArr, 1), UBound(oArr, 2)).Value = oArr
End With
you can try this code:
Option Explicit
Sub concatena()
Dim iRow As Long, iCol As Long, iCol2 As Long
Dim arr As Variant
With Worksheets("numbers")
With .Cells(1, 1).CurrentRegion
ReDim arr(1 To .Rows.Count, 1 To .Columns.Count / 3 + .Columns.Count Mod 3)
For iRow = 1 To .Rows.Count
iCol2 = 1
For iCol = 1 To .Columns.Count Step 3
arr(iRow, iCol2) = Join(Application.Transpose(Application.Transpose(.Cells(iRow, iCol).Resize(, 3).Value)), "")
iCol2 = iCol2 + 1
Next iCol
Next iRow
Worksheets("results").Range("A1").Resize(.Rows.Count, UBound(arr, 2)).Value = arr
End With
End With
End Sub
This solution provides flexibility as it uses the variable bClls to hold the number of cells to be concatenated.
Assuming the source range is B2:M16 and you want to concatenate the value of every 3 cells for each row.
It avoids the use of redim.
Sub Range_Concatenate_Cells_TEST()
Dim rSel As Range
Dim bClls As Byte
Dim rCllOut As Range
bClls = 3 'change as required
Set rSel = ThisWorkbook.Sheets("Sht(0)").Range("B2:M16") 'change as required
Set rCllOut = ThisWorkbook.Sheets("Sht(1)").Cells(2, 2) 'change as required
Call Range_Concatenate_Cells(bClls, rSel, rCllOut)
End Sub
Sub Range_Concatenate_Cells(bClls As Byte, rSel As Range, rCllOut As Range)
Dim lRow As Long, iCol As Integer
Dim lRowOut As Long, iColOut As Integer
Dim vResult As Variant
With rSel
For lRow = 1 To .Rows.Count
lRowOut = 1 + lRowOut
iColOut = 0
For iCol = 1 To .Columns.Count Step 3
iColOut = 1 + iColOut
vResult = .Cells(lRow, iCol).Resize(1, 3).Value2
vResult = WorksheetFunction.Index(vResult, 0, 0)
vResult = Join(vResult, "")
rCllOut.Offset(-1 + lRowOut, -1 + iColOut).Value = vResult
Next: Next: End With
End Sub
I have 2 table "PurposefulSample" and "scaled". This macro is being written for scaled.
Now when I run this one, it throws a 1004 at rowMax = Application.WorksheetFunction.Max(Range(src.Cells(curRow, 11), src.Cells(curRow, 37))).
Some cells in the given range are also strings. Few others are #N/A too.
Noob in VB. Really appreciate any help.
Sub stdInScaled()
Dim curCol, curRow
curRow = 2
Dim src As Worksheet
Set src = Worksheets("PurposefulSample")
Do While (src.Cells(curRow, 1).Value <> "")
curCol = 11
Do While (CStr(src.Cells(curRow, curCol).Value) <> "")
If (IsNumeric(src.Cells(curRow, curCol).Value)) Then
Dim rowMax
rowMax = Application.WorksheetFunction.Max(Range(src.Cells(curRow, 11), src.Cells(curRow, 37)))
If (rowMax > 1) Then
Cells(curRow, curCol).Value = 100 * CLng(src.Cells(curRow, curCol).Value) / rowMax
Else
Cells(curRow, curCol).Value = "No Business"
End If
Else
Cells(curRow, curCol).Value = "Data NA"
End If
curCol = curCol + 1
Loop
curRow = curRow + 1
Loop
End Sub
Two things:
It is always good practice to qualify the parentage of all range objects, just to ensure no mix up of which cell is being referenced.
With the chance of errors being in the data, an array formula Max will need to used to skip the errors. Also on the formula lets move it up one loop so it does not recalc the same answer every column.
code:
Sub stdInScaled()
Dim curCol, curRow
curRow = 2
Dim src As Worksheet
Set src = Worksheets("PurposefulSample")
Dim trgt As Worksheet
Set trgt = Worksheets("scaled")
Do While (src.Cells(curRow, 1).Value <> "")
curCol = 11
Dim rowMax
Dim rng As String: rng = src.Range(src.Cells(curRow, 11), src.Cells(curRow, 37)).Address
rowMax = src.Evaluate("Max(IF(isnumber(" & rng & ")," & rng & "))")
Do While (CStr(src.Cells(curRow, curCol).Value) <> "")
If (IsNumeric(src.Cells(curRow, curCol).Value)) Then
If (rowMax > 1) Then
trgt.Cells(curRow, curCol).Value = 100 * CLng(src.Cells(curRow, curCol).Value) / rowMax
Else
trgt.Cells(curRow, curCol).Value = "No Business"
End If
Else
trgt.Cells(curRow, curCol).Value = "Data NA"
End If
curCol = curCol + 1
Loop
curRow = curRow + 1
Loop
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
The below is my code. I have tried many different solutions but none seem to work. Any help would be appreciated.
Sub MultiDimensiionArray1()
'array for sheet one and sheet two
Dim myArraySheet1(0 To 3, 0 To 4) As Variant
Dim myArraySheet2(0 To 5, 0 To 4) As Variant
Dim i As Long, j As Long ' dimension counter for for sheet one
Dim Dimension1 As Long, Dimension2 As Long ' dimension counter for for sheet one
'number of rows in sheet one
Dim x As Integer, NumRows As Integer
Sheet1.Activate
NumRows = Range("B2", Range("B2").End(xlDown)).Rows.Count
'store everything on sheet one in array
For i = LBound(myArraySheet1, 1) To UBound(myArraySheet1, 1)
For j = LBound(myArraySheet1, 2) To UBound(myArraySheet1, 2)
myArraySheet1(i, j) = Range("A2").Offset(i, j).Value
Next j
Next i
'store everything on sheet two in array
Sheet2.Activate
For Dimension1 = LBound(myArraySheet2, 1) To UBound(myArraySheet2, 1)
For Dimension2 = LBound(myArraySheet2, 2) To UBound(myArraySheet2, 2)
myArraySheet2(Dimension1, Dimension2) = Range("A2").Offset(Dimension1, Dimension2).Value
Next Dimension2
Next Dimension1
'READ FROM ARRAY/OR DISPLAY THE RESULT
Sheet1.Activate
' Select sheet one cell G2
Range("G2").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
For i = LBound(myArraySheet1, 1) To UBound(myArraySheet1, 1)
For j = LBound(myArraySheet1, 2) To UBound(myArraySheet1, 2)
For Dimension1 = LBound(myArraySheet2, 1) To UBound(myArraySheet2, 1)
For Dimension2 = LBound(myArraySheet2, 2) To UBound(myArraySheet2, 2)
'if sheet one row equal to sheet two row execute the below code
If myArraySheet1(i, j) = myArraySheet2(Dimension1, Dimension2) Then
ActiveCell.Value = "YES IT IS DUPE AND NOT RESOLVED"
ActiveCell.Interior.ColorIndex = 4
ActiveCell.Font.ColorIndex = 2
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.Value = "Brand New"
ActiveCell.Interior.ColorIndex = 3
ActiveCell.Font.ColorIndex = 2
End If
Next Dimension2
Next Dimension1
Next j
Next i
Next
End Sub
I did not use array but the code below give you the expected output that you want:
Option Explicit
Sub Compare()
Dim wb As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim Lastrow As Long, Lastrow2 As Long
Dim i As Integer, j As Integer, c As Integer
Dim FOUND As Boolean
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("Sheet1")
Set ws2 = wb.Sheets("Sheet2")
Lastrow = ws1.Range("A" & Rows.Count).End(xlUp).Row
Lastrow2 = ws2.Range("A" & Rows.Count).End(xlUp).Row
i = 2
Do
FOUND = False
For j = 2 To Lastrow2
For c = 1 To 5
If ws1.Cells(i, c).Value = ws2.Cells(j, c).Value Then
FOUND = True
Else
FOUND = False
Exit For
End If
Next c
If FOUND = True Then
ws1.Cells(i, 7) = "YES IT IS DUPE AND NOT RESOLVED"
Exit For
End If
Next j
If FOUND = False Then
ws1.Cells(i, 7) = "Brand new"
End If
i = i + 1
Loop While i < Lastrow + 1
End Sub
With this you'll have two arrays containing values of cells that aren't equal so you'll be able to use the values you need to do what you want
Sub Test()
Dim DiffSh1() As Variant
Dim DiffSh2() As Variant
Call Compare_Sheets(ThisWorkbook.Sheets("Sheet1"), ThisWorkbook.Sheets("Sheet2"), DiffSh1, DiffSh2)
'Now you can use the values in the two arrays as you need
For x = LBound(DiffSh1, 1) To UBound(DiffSh1, 1)
For y = LBound(DiffSh1, 2) To UBound(DiffSh1, 2)
If DiffSh1(x, y) <> "" Then
MsgBox ("Cell at Row " & x & " Column " & y & " isn't equal:" & vbCrLf & _
"Value in sheet1 is: " & DiffSh1(x, y) & vbCrLf & _
"Value in sheet2 is: " & DiffSh2(x, y))
End If
Next y
Next x
End Sub
Public Sub Compare_Sheets(ByVal Sh1 As Worksheet, ByVal Sh2 As Worksheet, ByRef DiffIn1() As Variant, ByRef DiffIn2() As Variant)
Dim LastCol
Dim LastRow
LastCol = Sh1.Cells(1, 1).SpecialCells(xlLastCell).Column
If Sh2.Cells(1, 1).SpecialCells(xlLastCell).Column > LastCol Then
LastCol = Sh2.Cells(1, 1).SpecialCells(xlLastCell).Column
End If
LastRow = Sh1.Cells(1, 1).SpecialCells(xlLastCell).Row
If Sh2.Cells(1, 1).SpecialCells(xlLastCell).Row > LastRow Then
LastRow = Sh2.Cells(1, 1).SpecialCells(xlLastCell).Row
End If
ReDim DiffIn1(1 To LastRow, 1 To LastCol)
ReDim DiffIn2(1 To LastRow, 1 To LastCol)
Dim mCol As Long, mRow As Long
For mCol = 1 To LastCol
For mRow = 1 To LastRow
If Sh1.Cells(mRow, mCol) <> Sh2.Cells(mRow, mCol) Then
DiffIn1(mRow, mCol) = Sh1.Cells(mRow, mCol).Value
DiffIn2(mRow, mCol) = Sh2.Cells(mRow, mCol).Value
Else
DiffIn1(mRow, mCol) = ""
DiffIn2(mRow, mCol) = ""
End If
Next mRow
Next mCol
End Sub