Goes directly to MsgBox without seemingly changing anything.
I've been playing around with this code for awhile now since I'm new to VBA. I'm aware this script isn't pointed at a specific spreadsheet.
Private Sub MergeData()
'The cell it will use to search
Dim idCheck As Range
'The cell it will use to compare text
Dim currentCell As Range
'The cell is will use to compare duplicates
Dim oneRowBelow As Range
'Will briefly say if something changed in furthest column
Dim changes As String
'This will be used to format the "Changes" column
Dim rowNumberValue As Integer, columnNumberValue As Integer, rowBelow As Integer
colNum = 3
rowNumberValue = ActiveCell.Row
columnNumberValue = ActiveCell.Column
rowBelow = ActiveCell.Row + 1
'Searches by ID column
For Each idCheck In Worksheets("Test").Range("B2:B1000")
'This checks to find duplicate ID rows
If idCheck.Value = idCheck.Offset(-1, 0).Value Then
'Goes from each column starting from the ID column (H = 7th letter in alphabet and H is the last column)
'Technically S is the last column since S just lists what has changed
For colNum = 3 To 7
'Checks to see if the current cell has no value but the duplicate cell does
If Cells(rowNumberValue, colNum) = "" And Cells(rowBelow, colNum) <> "" Then
'Changes current cell value to the duplicate cell value
Cells(rowNumberValue, colNum) = Cells(rowBelow, colNum)
'Writes in the 19th column whether or not data has been changed
changes = "Added"
Cells(rowNumberValue, 19) = changes
Cells(rowNumberValue, 19).Interior.ColorIndex = 4
End If
'Checks to see if current cell has value but the duplicate cell doesn't
If Cells(rowNumberValue, colNum) <> "" And Cells(rowBelow, colNum) = "" Then
'Merges the two cells ( Unfortunately .Merge takes the top cell value only)
Range(Cells(rowNumberValue, colNum), Cells(rowBelow, colNum)).Merge
'Writes in the 19th column whether or not data has been changed
changes = "Added"
Cells(rowNumberValue, 19) = changes
Cells(rowNumberValue, 19).Interior.ColorIndex = 4
End If
'Checks to see if the cell value is different from the duplicate value
If Cells(rowNumberValue, colNum) <> Cells(rowBelow, colNum) Then
'This just sets the first value to the duplicate value (since it doesn't matter which one is overwritten)
Cells(rowBelow, colNum) = Cells(rowNumberValue, colNum)
'Writes in the 19th column whether or not data has been changed
changes = "Changed"
Cells(rowNumberValue, 19) = changes
Cells(rowNumberValue, 19).Interior.ColorIndex = 6
End If
Next colNum
End If
colNum = 3
Next
MsgBox "All done"
End Sub
So for example, if two rows have the number 123 in their ID column, and the Name column in the first row lists Timothy and the second row lists Tim, the script should change the row to say Bob and say in the furthest column what was changed. Or, if the first or second row has an empty cell while the other row doesn't, the data from the non-empty cell would be merged/copied over to the empty one.
It doesn't matter which data is overwritten, as long as all empty cells that can be filled, are filled.
From my comment, I believe you're causing false conditions due to where your variables are defined:
'Searches by ID column
For Each idCheck In Worksheets("Test").Range("B2:B1000")
'find current cell's row to be used in if-statements
rowNumberValue = ActiveCell.Row 'MOVED INTO ROW LOOP ==============
rowBelow = ActiveCell.Row + 1 'MOVED INTO ROW LOOP ==============
'This checks to find duplicate ID rows
If idCheck.Value = idCheck.Offset(-1, 0).Value Then
'Goes from each column starting from the ID column (H = 7th letter in alphabet and H is the last column)
'Technically S is the last column since S just lists what has changed
For colNum = 3 To 7 'COLNUM IS DEFINED, NOT NEEDED BEFOREHAND ==========
columnNumberValue = ActiveCell.Column 'if you need this, put it inside of this section, but you shouldn't need it due to colNum existing =========
'Your other code here
Next colNum
End If
Next
You also don't need to reset, manually, your colNum to 3 at the end, due to the For loop doing that when it iterates.
Flagged my comments/changes in your code with ======== after the comments.
Related
I am trying to get VBA to look at values in one column, and then check if the same value exists in another column.
I am then trying to highlight the same number of cells in both columns where the same value shows up, meaning that if the same value shows up a different amount of times in one column than in the other, I need to highlight the same amount of cells in each column and leave any "excess" duplicate values without highlight.
The picture illustrates what I am trying to accomplish. EXCEL SCREENSHOT
As seen in the picture, the values have been highlighted to the degree that they show up in either column, leaving the additional duplicate values without highlight.
I tried this code but it did not work and highlighted cells that I did not expect to get highlighted. I tried to loop through the columns and ignore already highlighted cells.
Sub highlightMatchingValues()
'Declare variables
Dim cellC As Range, cellE As Range
'Loop through each cell with a value in column C
For Each cellC In Range("C:C").Cells
If Not IsEmpty(cellC) And cellC.Interior.ColorIndex = xlNone Then 'ignore empty cells and cells that are already highlighted
'Loop through each cell with a value in column E
For Each cellE In Range("E:E").Cells
If Not IsEmpty(cellE) And cellE.Interior.ColorIndex = xlNone Then 'ignore empty cells and cells that are already highlighted
If cellC.value = cellE.value Then 'check for a match
'Highlight both cells green
cellC.Interior.Color = vbGreen
cellE.Interior.Color = vbGreen
End If
End If
Next cellE
End If
Next cellC
End Sub
here comes a solution that can solve your problem
'Sheet name = sheetName
'First columns variables (column C = index 3)
Dim firstLine1 As Long
Dim lastLine1 As Long
firstLine1 = 1
lastLine1 = Worksheets("sheetName").Cells(Rows.Count, 3).End(xlUp).Row
'Second columns variables (column E = index 5)
Dim firstLine2 As Long
Dim lastLine2 As Long
firstLine2 = 1
lastLine2 = Worksheets("sheetName").Cells(Rows.Count, 5).End(xlUp).Row
'loop
For i = firstLine1 To lastLine1
For j = firstLine2 To lastLine2
If (Worksheets("sheetName").Cells(i, 3).Value = Worksheets("sheetName").Cells(j, 5)) Then
If (Worksheets("sheetName").Cells(j, 5).Interior.Color <> vbGreen) Then
Worksheets("sheetName").Cells(i, 3).Interior.Color = vbGreen
Worksheets("sheetName").Cells(j, 5).Interior.Color = vbGreen
Exit For
End If
End If
Next j
Next i
I'm writing code that searches through a very large excel sheet with a lot of duplicates, I can easily sort the duplicates together as they all have 1 matching column, and ID column. The thing that I am stuck on is why IsEmpty isn't working for looking at the current cell and seeing if it's empty and if the next cell (the duplicate) has data. Then the cell with data would merge over into the cell that's empty.
I've tried using Range as the argument as well as cells to no avail.
Private Sub CountDuplicates()
Dim i As Integer
'The cell it will use to search
Dim idCheck As Range
'The cell it will use to compare text
Dim currentCell As Range
'This will be used to format the "Changes" column
Dim rowNumberValue As Integer, columnNumberValue As Integer, rowBelow As Integer
placement = 0
colNum = 3
rowNumberValue = ActiveCell.Row
columnNumberValue = ActiveCell.Column
rowBelow = ActiveCell.Row + 1
'Searches by ID column
For Each idCheck In Worksheets("Sheet1").Range("B2:B1000")
'This checks to find duplicate ID rows
If idCheck.Value = idCheck.Offset(-1, 0).Value Then
'Goes from each column starting from the ID column (H = 7th letter in alphabet and H is the last column)
For colNum = 3 To 7
'Checks to see if the cell has no value but the duplicate does
If IsEmpty(Range(Cells(rowNumberValue, colNum))) = True And IsEmpty(Range(Cells(rowNumberValue + 1, colNum))) = False Then
Range(Cells(rowNumberValue, colNum), Cells(rowBelow, colNum)).Merge
So ideally, if a row has one cell missing data, but the other row has it, then merge/copy the data into the cell with missing data.
Replace tests like:
IsEmpty(Range(Cells(rowNumberValue, colNum))) = True
with:
Cells(rowNumberValue, colNum) = ""
I'm currently looking for a code to improve my Dashboard. Actually, I need to know how to use a loop in a column X who will affect a column Y (cell on the same line).
To give you an example:
Column A: I have all Production Order (no empty cell)
Column B: Cost of goods Sold (Sometimes blank but doesn't matter)
I actually pull information from SAP so my Column B is not in "Currency".
The action should be:
If A+i is not empty, then value of B+i becomes "Currency".
It's also for me to get a "generic" code that I could use with other things.
This is my current code...
Sub LoopTest()
' Select cell A2, *first line of data*.
Range("A2").Select
' Set Do loop to stop when an empty cell is reached.
Do Until IsEmpty(ActiveCell)
ActiveCell.Offset(0, 1).Style = "Currency"
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Another example, getting Last Row, in case your data contains any blank rows.
Sub UpdateColumns()
Dim wks As Worksheet
Dim lastRow As Long
Dim r As Long
Set wks = ActiveSheet
lastRow = ActiveSheet.Cells.SpecialCells(xlLastCell).Row
For r = 2 To lastRow
If wks.Cells(r, 1) <> "" Then
wks.Cells(r, 2).NumberFormat = "$#,##0.00"
End If
Next r
End Sub
I can see I was a little slower than the others, but if you want some more inspiration, heer is a super simple solution (as in easy to understand as well)
Sub FormatAsCurrency()
'Dim and set row counter
Dim r As Long
r = 1
'Loop all rows, until "A" is blank
Do While (Cells(r, "A").Value <> "")
'Format as currency, if not blank'
If (Cells(r, "B").Value <> "") Then
Cells(r, "B").Style = "Currency"
End If
'Increment row
r = r + 1
Loop
End Sub
Try the following:
Sub calcColumnB()
Dim strLength As Integer
Dim i As Long
For i = 1 To Rows.Count
columnAContents = Cells(i, 1).Value
strLength = Len(columnAContents)
If strLength > 0 Then
Cells(i, 2).NumberFormat = "$#,##0.00"
End If
Next i
End Sub
Explanation--
What the above code does is for each cell in Column B, so long as content in column A is not empty, it sets the format to a currency with 2 decimal places
EDIT:
Did not need to loop
Here's a really simply one, that I tried to comment - but the formatting got messed up. It simply reads column 1 (A) for content. If column 1 (A) is not empty it updates column 2 (B) as a currency. Changing active cells makes VBA more complicated than it needs to be (in my opinion)
Sub LoopTest()
Dim row As Integer
row = 1
While Not IsEmpty(Cells(row, 1))
Cells(row, 2).Style = "Currency"
row = row + 1
Wend
End Sub
I am looking for a quick way to fill some fields based on a the following condition. (See image)
I have a list containing 3 columns. I need to fill Column C depending on the letter in Column A. When I go to C34 I would like to automatically search the rows above and based on the letter in Column A copy the 11 names from the latest occurrence above. So in C34-C44 the names from C1-C11 would get copied as a block.
Is there a function in Excel that can do that?
You can use a simple VBA macro with two FOR loops to solve your issue:
Sub CompleteRows()
Dim lastrow As Long
lastrow = Cells(Rows.Count, "A").End(xlUp).Row 'finds last row in column A
For x = 1 To lastrow 'loop that starts with value 1 and goes all the way to the value of lastrow
If Cells(x, 3).Value = "" Then 'if value in column C is empty then continue on
For y = 1 To lastrow 'second loop that runs through the same range
If Cells(y, 1).Value = Cells(x, 1).Value And Cells(y, 2).Value = Cells(x, 2).Value Then
'If the value of the first column and the value of the second
'column for both values match, then add value to column C
Cells(x, 3).Value = Cells(y, 3).Value
Exit For 'Exit loop if value was found
End If
Next y
End If
Next x
End Sub
I have been trying to create a simple macro that takes all duplicate records from a source sheet and pastes them into a new sheet.
I have been messing around, and the closest I've gotten is the creation of a list that extracts all duplicate values except for the first duplicate value in a cluster.
So for example, if a list looks like this below:
1
1
2
3
4
5
1
The sheet with the duplicates will list:
1
1
It will consider the first instance of '1' as unique, and that is totally not what I want. I want it to show every single instance of the duplicated row, so I awnt this:
1
1
1
Here's what I do to deal with duplicates. It isn't a macro, but works for me:
Sort the column with the duplicate. (For this example, say column C)
In a new column, write an IF function. Eg in cell D5: =if(c5=c4,1,"")
Copy cell D5 to the entire list.
Copy and paste value column D over itself. Eg in step 2, the formula is replaced with a "1"
Sort column D
Any row with a 1 is a duplicate. Do as you wish!
You can also do things like find the sum of column D (shows me how many duplicates)
After clarifications by OP the following procedure will perform as required:
Sub CopyDuplicates()
'***************************************************************
'** This proc expects you to select all the cells in a single **
'** column that you want to check for duplicates in. If dup- **
'** licates are found, the entire row will be copied to the **
'** predetermined sheet. **
'***************************************************************
Dim ShO As Worksheet
Dim Rng1 As Range
Dim pRow As Integer
Dim c As Range, cTmp As Range
Dim found
Dim Addresses() As String
Dim a() As String
Dim p2 As Integer
Dim tfFlag As Boolean, sTmp As Variant
Set ShO = Worksheets("Sheet2") 'You can change this to whatever worksheet name you want the duplicates in
Set Rng1 = Application.Selection 'Rng1 is all the currently selected cells
pRow = 1 'This is the first row in our outpur sheet that will be used to record duplicates
ReDim a(0) 'Initialize our array that holds found values
For Each c In Rng1.Cells 'Cycle through each cell in our selected range
ReDim Addresses(0) 'This array holds the cell address for our duplicates.
'We will reset the array each time we move to the next cell
'Now check the array of already found duplicates.
'If the current value is already there skip to next value
tfFlag = False
For Each sTmp In a
If CStr(c.Value) = sTmp Or CStr(c.Value) = "xXDeleteXx" Then 'We've already done this value, move on
tfFlag = True
Exit For
End If
Next
If Not tfFlag Then 'Remember the flag is true when we have already located the
'duplicates for this value, so skip to next value
With Rng1
Set found = .Find(c.Value, LookIn:=xlValues) 'Search entire selected range for value
If Not found Is Nothing Then 'Found it
Addresses(0) = found.Address 'Record the address we found it
Do 'Now keep finding occurances of it
Set found = .FindNext(found)
If found.Address <> Addresses(0) Then
ReDim Preserve Addresses(UBound(Addresses) + 1)
Addresses(UBound(Addresses)) = found.Address
End If
Loop While Not found Is Nothing And found.Address <> Addresses(0) 'Until we get back to the original address
If UBound(Addresses) > 0 Then 'We Found Duplicates
a(UBound(a)) = c.Value 'Record the value we found a duplicate for in an array
ReDim Preserve a(UBound(a) + 1) 'add an empty spot to the array for next value
ShO.Range("A" & pRow).Value = "Duplicate Rows for Value " & c.Value & _
" in Column " & c.Column & " on original sheet" 'Add a label row
pRow = pRow + 1 'Increment to the next row
For p2 = UBound(Addresses) To 0 Step -1 'Cycle through the duplicate addresses
Set cTmp = Rng1.Worksheet.Range(Addresses(p2)) 'we just want to easily get the correct row to copy
Rng1.Worksheet.Rows(cTmp.Row).Copy ShO.Rows(pRow) 'Copy form orig to duplicates sheet
cTmp.Value = "xXDeleteXx" 'Mark for Delete the original row
pRow = pRow + 1 'Increment row counter
Next p2
pRow = pRow + 1 'This increment will give us a blank row between sets of dupicates
End If
End If
End With
End If
Next
'Now go delete all the marked rows
Do
tfFlag = False
For Each c In Rng1
If c.Value = "xXDeleteXx" Then
Rng1.Worksheet.Rows(c.Row).Delete (xlShiftUp)
tfFlag = True
End If
Next
Loop Until tfFlag = False
End
End Sub