VBA Why is my macro reading column 5 instead of 3 - vba

I wrote a macro to insert a row between cells when their values are different. I have 9 columns in my data and the data starts at row 2. I want my macro to check all the values down column 3 (also known as column "C") and as it goes through, if the value changes (i.e. 2, 2, 2, 3, 3) it will insert a row between the changed value (i.e. 2, 2, 2, INSERT ROW, 3, 3). The problem is, my macro is reading column 5(E) not 3(C). What is wrong with it, I can't figure it out! The reason I know this too is because I placed a msgbox to spit the value of the cell and it matches everything in column 5 but not 3. Here is my code:
Sub Dividers()
Dim DividerRange As Range, lastrow As Long, k As Integer, counter As Integer
lastrow = Range("C2").End(xlDown).Row
Set DividerRange = Range(Cells(2, 3), Cells(lastrow, 3))
counter = 0
For k = 2 To DividerRange.Count
MsgBox DividerRange(k + counter, 3).Value
If DividerRange(k + counter, 3).Value = DividerRange(k + counter - 1, 3).Value Then
DividerRange(k + counter, 3).EntireRow.Insert
counter = counter + 1
Else
End If
Next k
End Sub

DividerRange(k + counter, 3).Value is a relative reference. DividerRange is a range starting at C2, so when you ask for the (i,j)th cell, i.e. (i,3) you get something from column E where jth columns would be: (C = 1, D = 2, E = 3)

You can simplify it quite a lot, there's no need for the Range or Range count, or counter:
Sub Dividers()
Dim lastrow As Long, k As Integer
lastrow = Range("C2").End(xlDown).Row
For k = 2 To lastrow
If Cells(k, 3).Value <> Cells(k - 1, 3).Value Then
Cells(k, 3).EntireRow.Insert
'Now skip a row so we don't compare against the new empty row
k = k + 1
End If
Next k
End Sub

Related

Obtaining only unique combinations of with data from 1 column multiple rows VBA

I know how to create all the possible combinations but I'm having difficulties to obtain only the unique ones.
In my example I have 5 rows of data values (1,2,3,4,5) in A3:A7
My goal would be to get all the unique combinations with that data and not have the ones that repeat.
Here is the code that I have right now
Private Sub CommandButton1_Click()
For i = 3 To 7
Cells(i, 1) = i - 2
Next i
Cells(1, 3) = "number"
Cells(3, 3) = "combinations"
For i = 3 To 7
For Z = 3 To 6
last = Cells(3, Columns.Count).End(xlToLeft).Column
Range(Cells(3, 1), Cells(7, 1)).Copy Destination:=Range(Cells(3, last + 1), Cells(7, last + 1))
temp = Cells(i, 1)
Cells(i, last + 1) = Cells(Z + 1, 1)
Cells(Z + 1, last + 1) = temp
Next Z
Next i
End Sub
Here is possible to see what happens in the excel file
If the idea is to make some random range and see the unique cells, this is some option:
Create the range;
Put some random values in it;
Use the built-in formula for WorksheetFunction.CountIf() to see whether the value is unique;
If it is unique, color it in Magenta:
Option Explicit
Public Sub GenerateRandoms()
Dim someRange As Range
Set someRange = Range("A1:F20")
someRange.Clear
Dim myCell As Range
For Each myCell In someRange
myCell = MakeRandom(1, 50)
Next myCell
Dim someUniqueValues As Range
For Each myCell In someRange
If WorksheetFunction.CountIf(someRange, myCell) = 1 Then
myCell.Interior.Color = vbMagenta
End If
Next myCell
End Sub
Private Function MakeRandom(down As Long, up As Long) As Long
MakeRandom = CLng((up - down) * Rnd + down)
End Function

VBA: Generating numbers for unique values of range and returning them to the range (simulating dice rolls)

I am trying to implement a random number generation in an Excel sheet. The process is such:
There are seven cells, each containing the number and type of dice to be rolled in standard notation (XdY+Z, where X is the number of Y-sided dice to roll, with Z being the bonus/penalty)
The numbers are tallied up into unique groups by roll types
The numbers are generated for each group (I have this step working, so this isn't the problem).
One extra roll is made for each group
The lowest number is dropped
The numbers are assigned to an output range, in order, so they match their dice rows.
I know I can extract the unique values from my input using a collection. I also already have a function which interprets the dice type and makes the roll. I am stumped though about being able to tally up the unique values, roll that many times + 1, drop lowest and then return them to the correct rows. Especially since I don't want to sort the results.
I would appreciate any help or any direction in which you could point me.
Example:
Input:
1d6
1d6
1d8
1d10
1d4
1d6
1d4
Divide into buckets: 3 x 1d6; 1 x 1d8; 1 x 1d10; 2 x 1d4
Roll dice, with an extra roll for each bucket:
4 x 1d6 - 4, 4, 5, 2
2 x 1d8 - 8, 7
2 x 1d10 - 1, 3
3 x 1d4 - 1, 1, 4
Drop lowest value, leaving the following numbers:
1d6: 4, 4, 5
1d8: 8
1d10: 3
1d4: 1, 4
Assign them in order:
1d6 - 4
1d6 - 4
1d8 - 8
1d10 - 3
1d4 - 1
1d6 - 5
1d4 - 4
This is the original function, which simply goes down the list, generates the roll (through a RollDice function that performs the roll), and places it in the correct output cell:
Sub GenerateOld()
For i = 1 To 7
Range("Dice_Output").Cells(i).Value = _
RollDice(Range("Dice_Input").Cells(i).Value)
Next i
End Sub
This is my attempt at the new version of this code. Commented out are the sections I can't figure out:
Sub GenerateNew()
Dim diceDictionary
Set diceDictionary = CreateObject("Scripting.Dictionary")
For Each Cell In Range("Char_Characteristics_Dice").Cells
If diceDictionary.Exists(Cell.Value) Then
diceDictionary(Cell.Value) = diceDictionary(Cell.Value) + 1
Else
diceDictionary.Add Cell.Value, 1
End If
Next Cell
For Each diceType In diceDictionary
' RollDice(diceType)
' Roll X drop lowest
Next cont
' Place back into Dice_Output range in order
End Sub
Not sure if this is still needed, but I used a set of arrays to tackle this problem. Here's a summary of how I approached it:
Get the values from the range in Excel, pass them to the first array
Set up the number of times the dice needed to be rolled
Pass the first array to a 2D array and populate it with info to finish
Use a temporary array to get values from the rolls and then paste back into the Excel sheet
Sub roll()
Dim i As Long
Dim j As Long
Dim k As Long
Dim lr As Long
Dim upperbound As Long
Dim lowerbound As Long
Dim frequency As String
Dim rolls As String
Dim rng As Range
Dim arr1D() As String
Dim arr2D() As String
Dim rollresult As Integer
Dim arr_min As Variant
Dim FirstCheck As Boolean
Dim targetdi As Variant
'Set the area with values for the dice roll simulation
lr = Cells(Rows.Count, "A").End(xlUp).Row
'Clear the result area for roll results
Range(Cells(2, "B"), Cells(lr, "B")).ClearContents
Set rng = Range(Cells(2, "A"), Cells(lr, "A"))
'Collect unique values from the range
For Each cell In rng
If (cell <> "") And (InStr(frequency, cell) = 0) Then
frequency = frequency & cell & "|"
End If
Next cell
If Len(frequency) > 0 Then frequency = Left(frequency, Len(frequency) - 1)
arr1D = Split(frequency, "|")
'Set up the 2D array with a space for the number of rolls
ReDim arr2D(LBound(arr1D) To UBound(arr1D), LBound(arr1D) To 3)
'Copy contents from first (1D) array into the second (2D) array
For i = LBound(arr1D) To UBound(arr1D)
arr2D(i, 0) = arr1D(i)
arr2D(i, 1) = Application.WorksheetFunction.CountIf(Range(Cells(2, "A"), Cells(lr, "A")), "=" & arr2D(i, 0)) + 1
arr2D(i, 2) = Right(arr2D(i, 0), Len(arr2D(i, 0)) - InStr(1, arr2D(i, 0), "d"))
'Keep rollin rollin rollin WHAT Keep rollin rollin rollin
For j = 1 To (arr2D(i, 1))
If ((arr2D(i, 2)) <> "") Then
rollresult = Int((Int((arr2D(i, 2) + 1)) - 1 + 1) * Rnd + 1)
rolls = rolls & rollresult & "|"
End If
Next j
rolls = Left(rolls, Len(rolls) - 1)
arr2D(i, 3) = rolls
rolls = ""
Next i
For i = LBound(arr2D) To UBound(arr2D)
temparray = Split(arr2D(i, 3), "|")
arr_min = temparray(LBound(temparray))
For j = LBound(temparray) To UBound(temparray) 'LBound(temparray) To UBound(temparray) - 1
If temparray(j) < arr_min Then
arr_min = temparray(j)
End If
Next j
'Remove the lowest value, but preserve the order
For j = LBound(temparray) To UBound(temparray)
If temparray(j) = arr_min And FirstCheck = False Then
temparray(j) = ""
FirstCheck = True
End If
Next j
'Place the results back in the sheet
For j = LBound(temparray) To UBound(temparray)
If temparray(j) <> "" Then
targetdi = arr2D(i, 0)
For k = 2 To lr
If Cells(k, "A").Value = targetdi And Cells(k, "B").Value = "" Then
Cells(k, "B").Value = temparray(j)
End If
Next k
End If
Next j
Next i
End Sub

Copy and Paste Values for non-blank values with matching criteria VBA macro

I'm struggling to write the correct code to be able to Copy and Paste Values for non-blank values with matching criteria.
An example of what I'm trying to do can be seen here (Example)
What I would like the code to do is to take the values in the left hand range that are not blank, and paste the values into the right hand range where they match according to the labels in row A.
If the new values could paste as a highlighted color that would be helpful as well; however, my main struggle is mainly with the first part. (Picture of how it would look after the macro has run) - (Answer)
I have been able to figure this out by using excel formulas within my code; however, this is not ideal for the functionality of my workbook.
Thanks for the help! - It's much appreciated.
Update:
Sub Button2_Click()
Worksheets("Nielson"‌​).Range("AH3:CD9999")‌​.Formula = "=if(NOT(ISBLANK(vlo‌​okup($a3,Load!$P:$AD,‌​Load!R$4,False))),ife‌​rror(vlookup($a3,Load‌​!$P:$AD,Load!R$4,Fals‌​e),ch3),ch3)"
Worksheets("Nielson"‌​).Range("AH3:CD9999")‌​.Copy
Worksheets("Nielson"‌​).Range("CH3:CT9999")‌​.PasteSpecial xlPasteValues Worksheets("Nielson"‌​).Range("CH3:CT9999")‌​.Copy
Worksheets("Nielson"‌​).Range("AH3:CD9999")‌​.PasteSpecial xlPasteValues
End Sub
(code posted as comment by OP)
This can help you. Is a modification of this code.
Private Sub Button2_Click()
Dim vReplacementArray() As Variant
Dim iLastRowReplacements As Integer
Dim iLastRowData As Integer
Dim i As Integer, j As Integer, r As Integer, c As Integer
Dim ValToFind1 As String
iLastRowReplacements = Worksheets("Nielson").Cells(Rows.Count, 1).End(xlUp).Row
iLastRowData = Worksheets("Nielson").Cells(Rows.Count, 9).End(xlUp).Row
'Create an array with replacement data (left 6 columns in your example)
For i = 2 To iLastRowReplacements
ReDim Preserve vReplacementArray(1 To 6, 1 To i)
'You can loop here. I leave it hard-coded to make it clearer
vReplacementArray(1, i) = Worksheets("Nielson").Cells(i, 1).Value
vReplacementArray(2, i) = Worksheets("Nielson").Cells(i, 2).Value
vReplacementArray(3, i) = Worksheets("Nielson").Cells(i, 3).Value
vReplacementArray(4, i) = Worksheets("Nielson").Cells(i, 4).Value
vReplacementArray(5, i) = Worksheets("Nielson").Cells(i, 5).Value
vReplacementArray(6, i) = Worksheets("Nielson").Cells(i, 6).Value
Next
For i = 2 To iLastRowData 'Scan all rows with data, starting in row 2 (row 1 for titles)
'Get values from column I (ValToFind1)
ValToFind1 = Worksheets("Nielson").Cells(i, 9).Value
'Find those to values in the array, and write the replacement in their respective column
For c = 1 To UBound(vReplacementArray, 2)
If (vReplacementArray(1, c) = ValToFind1) Then
For j = 1 To 5 'The five columns (J to N in your example)
If (vReplacementArray(j + 1, c) <> "") Then 'if there is a value
Worksheets("Nielson").Cells(i, 9 + j).Value = vReplacementArray(j + 1, c)
Worksheets("Nielson").Cells(i, 9 + j).Interior.ColorIndex = 4
End If
Next j
End If
Next c
Next i
End Sub

VBA For next loop until last row of a column though not last row of sheet

I'm trying to run a For Next Loop until the last row of a specific column (but not the last row of the sheet). So the first part of my list has data in column F and the second part doesn't. I only want the macro to apply to that first part. For some reason the loop only runs through the first part with certain commands but doesn't with the ones I am trying to do now. (I know it would be easy just to seperate the two parts manually and then run it but it drives me nuts not knowing what it is I did wrong :)).
This is the code:
Dim i As Integer
Dim g As Double
g = 0.083333333
Dim lastrow As Long
lastrow = Sheets("zm").Range("f" & Rows.Count).End(xlUp).Row
Sheets("zm").Activate
For i = 2 To lastrow
If Sheets("zm").Cells(i, 1) = Sheets("zm").Cells(i + 1, 1) And Sheets("zm").Cells(i, 5) = Sheets("zm").Cells(i + 1, 5) And Sheets("zm").Cells(i + 1, 6) - Sheets("zm").Cells(i, 7) < g Then
Sheets("zm").Cells(i + 1, 7).Copy
Sheets("zm").Cells(i, 7).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Sheets("zm").Rows(i + 1).Delete
End If
Next i
Thanks for your help!
avoid Select/Selection and/or Activate/ActiveXXX
try this:
Option Explicit
Sub main()
Dim i As Long, lastrow As Long
Dim g As Double
g = 0.083333333
With Worksheets("zm")
lastrow = .Cells(.Rows.Count, "F").End(xlUp).Row
For i = lastrow To 2 Step -1
If .Cells(i, 1) = .Cells(i + 1, 1) And .Cells(i, 5) = .Cells(i + 1, 5) And .Cells(i + 1, 6) - .Cells(i, 7) < g Then
.Cells(i + 1, 7).Copy Destination:=.Cells(i, 7)
.Rows(i + 1).Delete
End If
Next i
End With
End Sub

VBA Macro Speed Up

I would appreciate some help on the following VBA Macro problem,
screenshot here:
I have to compare the data in 2 columns - Index & Sec_Index. In case of a match it should check which Values is assigned to the Sec_Index and fill a "1" to the matching Value column corresponding to Index and "0" for the other Value columns (I hope the screenshot explains it better)
I wrote a short macro which works good. However I have huge amounts of data - both Index columns contain at least 400000-500000 lines. This makes my code useless since it will take extreme long durations to execute.
Is there a way to make this work? I read about Variant arrays, but I'm not that familiar with them.
You can put this formula (if Excel 2007 or above):
=COUNTIFS($H$2:$H$5,$B2,$I$2:$I$5,"A")
into C2 and copy it down and across; just change "A" to "B" and "C".
Added In view of the number of rows, I would import the data into MS Access, create a Crosstab Query, then copy this data back to Excel.
Try this, not overly robust but does work. Not sure how quickly this will compare to what you may have had?
It did about 60,000 rows with 25 keys in about 5 seconds.
Edit: Added timer to function.
Public Declare Function GetTickCount Lib "kernel32.dll" () As Long
public Sub main()
Dim t As Long
t = GetTickCount
Application.ScreenUpdating = False
Dim Arr1(), Arr() As Double
Dim x, y, i, j As Double
Dim v As String
x = Cells(Rows.Count, 2).End(xlUp).Row - 2
y = Cells(Rows.Count, 8).End(xlUp).Row - 2
Range("c2", "e" & x + 2) = 0
ReDim Arr1(x)
ReDim Arr2(y)
i = 0
Do Until Cells(i + 2, 2) = ""
Arr1(i) = Cells(i + 2, 2)
i = i + 1
Loop
i = 0
Do Until Cells(i + 2, 8) = ""
Arr2(i) = Cells(i + 2, 2)
i = i + 1
Loop
i = 0
Do Until i > UBound(Arr1)
j = 0
Do Until j > UBound(Arr2)
If Arr1(i) = Arr2(j) Then
v = Cells(Arr2(j) + 1, 9)
Select Case v
Case "a"
Cells(i + 2, 3) = 1
Case "b"
Cells(i + 2, 4) = 1
Case "c"
Cells(i + 2, 5) = 1
End Select
Exit Do
End If
j = j + 1
Loop
i = i + 1
Loop
MsgBox GetTickCount - t, , "Milliseconds"
End Sub