I need to highlight cells in each row that are in excess of the value in Column AU for that row of data; then do this for the next row, but I cannot get the value of column AU to be iterative meaning changing to the next row's value.
Let me know what I'm doing wrong here.
Sub highlight()
Application.ScreenUpdating = False
Dim myRange As Range
Dim i As Long, j As Long
Set myRange = Range("F11:AP20")
For n = 11 To 20
For i = 1 To myRange.Rows.Count
For j = 1 To myRange.Columns.Count
If myRange.Cells(i, j).Value < Range(AUn).Value Then
myRange.Cells(i, j).Interior.Color = 65535
Else
myRange.Cells(i, j).Interior.ColorIndex = 2
End If
Next j
Next i
Next n
End Sub
You have 1 loop extra
AUn is being treated as a blank variable. I guess you want to work with relevant row in Col AU.
Is this what you are trying? (Untested)
I have commented the code so let me know if you still have any questions :)
Sub highlight()
Application.ScreenUpdating = False
Dim myRange As Range
Dim n As Long, j As Long
Dim ws As Worksheet
'~~> Change this to the relevant worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
'~~> Set your range
Set myRange = .Range("F11:AP20")
'~~> Loop through the rows (11 to 20 in this case)
For n = myRange.Row To (myRange.Row + myRange.Rows.Count - 1)
'~~> Loop through the columns (F to AP in this case)
For j = myRange.Column To (myRange.Column + myRange.Columns.Count - 1)
If .Cells(n, j).Value < .Range("AU" & n).Value Then
.Cells(n, j).Interior.Color = 65535
Else
.Cells(n, j).Interior.ColorIndex = 2
End If
Next j
Next n
End With
End Sub
Related
I wrote a little code to mark the differences in two different tables.
When I run the code, there are many right "hits", but for some reason, sometimes the exact same value is marked as different. This mostly happened with numbers or if the alignment is not the same.
To get rid of the alignment- and formatting- problem I wrote/found the following Code:
Sub makeBeautiful()
Dim n As Integer
Dim m As Integer
Dim wks As Worksheet
Dim sht As Worksheet
Set sht = ThisWorkbook.Worksheets("bank-accountsNew")
Dim sht2 As Worksheet
Set sht2 = ThisWorkbook.Worksheets("bank-accountsOld")
n = sht.UsedRange.Rows.Count
m = sht.UsedRange.Columns.Count
For j = 1 To m
For i = 1 To n
If sht.Cells(i, j).Value = "null" Then
sht.Cells(i, j).Value = " "
End If
Next i
Next j
For Each wks In Worksheets
wks.Cells.VerticalAlignment = xlTop
wks.Cells.HorizontalAlignment = xlLeft
Next wks
sht.Cells.NumberFormat = "General"
sht2.Cells.NumberFormat = "General"
End Sub
As far as I can tell, this works just fine.
To mark the differences, I have the following Code:
Sub changeFinder()
Dim n As Integer
Dim m As Integer
Dim p As Integer
Dim o As Integer
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer
Dim Result As String
Dim item1 As String
Dim item2 As String
Dim sht As Worksheet
Set sht = ThisWorkbook.Worksheets("bank-accountsNew")
Dim sht2 As Worksheet
Set sht2 = ThisWorkbook.Worksheets("bank-accountsOld")
n = sht.UsedRange.Rows.Count
m = sht.UsedRange.Columns.Count
k = sht2.UsedRange.Rows.Count
l = sht2.UsedRange.Rows.Count
For j = 1 To m
sht.Columns(j + 1).Insert
sht.Columns(j + 1).Insert
For i = 2 To n
sht.Cells(i, j + 1).Value = Application.VLookup(sht.Cells(i, 1), sht2.Columns(1).Resize(, j), j, False)
Next i
For i = 2 To n
item1 = sht.Cells(i, j).Text
item2 = sht.Cells(i, j + 1).Text
Result = StrComp(item1, item2)
sht.Cells(i, j + 2) = Result
Next i
For i = 2 To n
If sht.Cells(i, j + 2) = 1 Then
sht.Cells(i, j).Interior.Color = vbRed
End If
Next i
sht.Columns(j + 1).Delete
sht.Columns(j + 1).Delete
Next j
End Sub
My idea was to create two new column next to every column I want to compare. Fill these two new column with the fitting value and a number to check either these values are the same or not. If not, the original value should be marked in red.
I have in both table almost the same bank accounts numbers as column 3.
Some of them are marked as different and some them are not marked as different, but in only case they are not the same. So, my code does not work properly.
As far as I can tell, every value is equally aligned and equally formatted, so I don´t know what could cause Excel to think that the same numbers are different. :/
Table B is created by a json.file. Table A ist created by PowerQuery with two tables, which I have from a json.file.
I hope someone can help me here a litle bit.
Sincerely,
Julian
Rather than repeated VLookups consider using a Dictionary Object.
Option Explicit
Sub changeFinder()
Dim sht1 As Worksheet, sht2 As Worksheet
Dim lastrow As Long, r As Long, r2 As Long
Dim lastcol As Long, c As Long
With ThisWorkbook
Set sht1 = .Sheets("bank-accountsNew")
Set sht2 = .Sheets("bank-accountsOld")
End With
' build look up to sheet2
Dim dict As Object, id As String, n As Long
Set dict = CreateObject("Scripting.Dictionary")
With sht2
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
' scan down sheet
For r = 2 To lastrow
id = Trim(.Cells(r, 1))
If dict.exists(id) Then
MsgBox "Error - duplicate id " & id, vbCritical, sht2.Name & " row " & r
Exit Sub
ElseIf Len(id) > 0 Then
dict.Add id, r
End If
Next
End With
' compare with sheet 1
With sht1
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
With .UsedRange
lastcol = .Columns.Count
.Interior.Color = xlNone 'clear sheet
End With
' scan down sheet
For r = 2 To lastrow
id = Trim(.Cells(r, 1))
' check exists on sheet2
If Not dict.exists(id) Then
.Rows(r).Interior.Color = RGB(128, 255, 128)
n = n + 1
Else
r2 = dict(id) ' sheet 2 row
' scan across columns
For c = 2 To lastcol
If Trim(.Cells(r, c)) <> Trim(sht2.Cells(r2, c)) Then
.Cells(r, c).Interior.Color = RGB(255, 128, 0)
n = n + 1
'Debug.Print .Cells(r, c), sht2.Cells(r2, c)
End If
Next
End If
Next
End With
' result
If n > 0 Then
MsgBox n & " differences found", vbExclamation
Else
MsgBox "No differences found", vbInformation
End If
End Sub
I have multiple columns in an excel sheet...say A1:D10.
I want to find any blank cells in column C, delete that cell as well as the A,B, and D cells of that same row, then shift up. But only in the range of A1:D10. I have other information in this excel sheet outside this range that I want to perserve in its original position. Therefore I can not use somthing like this:
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Nor can I get something like the following to work, because it only shifts the single column up, not all four columns.
Set rng = Range("A1:D10").SpecialCells(xlCellTypeBlanks)
rng.Rows.Delete Shift:=xlShiftUp
If there is no data in columns A to D below row 10 that you don't want to move up, then SpecialCells and Delete Shift Up can be used like this
Sub Demo1()
Dim ws As Worksheet
Dim TestColumn As Long
Dim StartColumn As Long
Dim EndColumn As Long
Dim FirstRow As Long
Dim LastRow As Long
Dim i As Long
Dim rng As Range, arr As Range
' set up reference data
Set ws = ActiveSheet '<~~ update as required
TestColumn = 3 'C
StartColumn = 1 'A
EndColumn = 4 'D
FirstRow = 1
LastRow = 10
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With ws
On Error Resume Next
Set rng = .Range(.Cells(FirstRow, TestColumn), .Cells(LastRow, TestColumn)).SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not rng Is Nothing Then
For Each arr In rng.Areas
arr.EntireRow.Resize(, EndColumn - StartColumn + 1).Delete Shift:=xlShiftUp
Next
End If
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
If there is data in columns A to D below row 10 that you don't want to move up, then you can use Cut and Paste, like this
Sub Demo()
Dim ws As Worksheet
Dim TestColumn As Long
Dim StartColumn As Long
Dim EndColumn As Long
Dim FirstRow As Long
Dim LastRow As Long
Dim i As Long
' set up reference data
Set ws = ActiveSheet '<~~ update as required
TestColumn = 3 'C
StartColumn = 1 'A
EndColumn = 4 'D
FirstRow = 1
LastRow = 10
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With ws
If IsEmpty(.Cells(LastRow, TestColumn)) Then
.Cells(LastRow, StartColumn).Resize(1, EndColumn - StartColumn + 1).Clear
End If
For i = LastRow - 1 To FirstRow Step -1
If IsEmpty(.Cells(i, TestColumn)) Then
.Range(.Cells(i + 1, StartColumn), .Cells(LastRow, EndColumn)).Cut .Cells(i, StartColumn)
End If
Next
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Using Variant Array Method
Sub test2()
Dim rngDB As Range, vDB As Variant
Dim i As Integer, j As Integer, n As Integer
Dim k As Integer
Set rngDB = Range("a1:d10")
vDB = rngDB
n = UBound(vDB, 1)
For i = 1 To n
If IsEmpty(vDB(i, 3)) Then
For j = 1 To 4
If j <> 3 Then
vDB(i, j) = Empty
End If
Next j
End If
Next i
For j = 1 To 4
If j <> 3 Then
For i = 1 To n - 1
For k = i To n - 1
If vDB(k, j) = Empty Then
vDB(k, j) = vDB(k + 1, j)
vDB(k + 1, j) = Empty
End If
Next k
Next i
End If
Next j
rngDB = vDB
End Sub
The below will take care of your requirement by looking for an empty cell in column 3, and deleting the row and shifting up only in that row.
Sub deleteEmptyRow()
Dim i As Integer
For i = 1 To 10
If Cells(i, 3) = "" Then
Range(Cells(i, 1), Cells(i, 4)).delete Shift:=xlUp
End If
Next i
End Sub
I'm trying to build a macro which will iterate through Activeworkbook/Activeworksheet& Range("A1:" & LastColumn & LastRow) and merge all duplicates in each column. The best starting point I could find was this post --> fastest way to merge duplicate cells in without looping Excel
But, like the OP comments on #PEH's answer https://stackoverflow.com/a/45739951/5079799 I get the following error Application defined error on the line Set R = .Range(Join(arr, ",")).
Does anybody have the fix and/or a better/alternative way to merge duplicates in a column?
Code from answer:
Sub MergeCellsNew()
Application.DisplayAlerts = False
Dim n As Name
Dim fc As FormatCondition
Dim Rng As Range, R As Range
Dim lRow As Long
Dim I&, J&
Dim arr As Variant
ReDim arr(1 To 1) As Variant
With ThisWorkbook.Sheets("tst")
Set Rng = .Range("A2:D11")
lRow = Rng.End(xlDown).Row
For J = 1 To 4
I = 2 'I = Rng.Row to automatically start at the first row of Rng
Do While I <= lRow
Set R = .Cells(I, J) 'remember start cell
'run this loop as long as duplicates found next to the start cell
Do While Trim(UCase(.Cells(I, J))) = Trim(UCase(.Cells(I + 1, J)))
Set R = R.Resize(R.Rows.Count + 1) 'and resize R + 1
I = I + 1
Loop
'now if R is bigger than one cell there are duplicates we want to add to the arr
'this way single cells are not added to the arr
If R.Rows.Count > 1 Then
arr(UBound(arr)) = R.Address
ReDim Preserve arr(1 To UBound(arr) + 1)
End If
I = I + 1
Loop
Next J
ReDim Preserve arr(1 To UBound(arr) - 1)
Set R = .Range(Join(arr, ","))
With R
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Stop
End With
Application.DisplayAlerts = True
End Sub
The problem I see with the methods outlined above is that it relies on duplicate data existing in an adjacent cell in the column. What if the duplicates are scattered in the column?
Here's an example where each column is examined by creating a Dictionary of all the values. Since each value must be unique (as the Key), then duplicates are removed with a list of just the unique Keys. Then it's just a matter of clearing the column of the previous data and copying the unique data back to the worksheet.
Option Explicit
Sub RemoveColumnDupes()
Dim lastCol As Long
With Sheet1
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
Dim c As Long
For c = 1 To lastCol
Dim columnDict As Dictionary
Set columnDict = CreateColumnDictionary(Sheet1, c)
If columnDict is Nothing then Exit For
'--- clear the existing data and replace with the cleaned up data
.Range("A1").Offset(, c - 1).Resize(.Rows.Count, 1).Clear
.Range("A1").Offset(, c - 1).Resize(columnDict.Count, 1) = KeysToArray(columnDict)
Next c
End With
End Sub
Private Function CreateColumnDictionary(ByRef ws As Worksheet, _
ByVal colIndex As Long) As Dictionary
Dim colDict As Dictionary
Dim lastRow As Long
With ws
lastRow = .Cells(.Rows.Count, colIndex).End(xlUp).Row
If lastRow = 1 Then
'--- can't create a dictionary with no data, so exit
Set colDict = Nothing
Else
Set colDict = New Dictionary
Dim i As Long
For i = 1 To lastRow
If Not colDict.Exists(.Cells(i, colIndex).Value) Then
colDict.Add .Cells(i, colIndex).Value, i
End If
Next i
End If
End With
Set CreateColumnDictionary = colDict
End Function
Private Function KeysToArray(ByRef thisDict As Dictionary) As Variant
Dim newArray As Variant
ReDim newArray(1 To thisDict.Count, 1 To 1)
Dim i As Long
For i = 1 To thisDict.Count
newArray(i, 1) = thisDict.Keys(i - 1)
Next i
KeysToArray = newArray
End Function
While I don't know the issue with the code I found and posted in OP. I did find awesome solutions on https://www.extendoffice.com and modified it to suit my needs as found below.
Test:
Sub MergeTest()
Dim wsrng As Range
Set wsrng = ActiveSheet.UsedRange
Call MergeWS(wsrng)
'Call UnMergeWS(wsrng)
End Sub
Merge:
https://www.extendoffice.com/documents/excel/1138-excel-merge-same-value.html
Function MergeWS(WorkRng As Range)
Dim Rng As Range, xCell As Range
Dim xRows As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
xRows = WorkRng.Rows.Count
For Each Rng In WorkRng.Columns
For i = 1 To xRows - 1
For j = i + 1 To xRows
If Rng.Cells(i, 1).Value <> Rng.Cells(j, 1).Value Then
Exit For
End If
Next
With WorkRng.Parent.Range(Rng.Cells(i, 1), Rng.Cells(j - 1, 1))
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
i = j - 1
Next
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Function
UnMerge:
https://www.extendoffice.com/documents/excel/1139-excel-unmerge-cells-and-fill.html
Function UnMergeWS(WorkRng As Range)
Dim Rng As Range, xCell As Range
xTitleId = "KutoolsforExcel"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each Rng In WorkRng
If Rng.MergeCells Then
With Rng.MergeArea
.UnMerge
.Formula = Rng.Formula
End With
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Function
https://www.freesoftwareservers.com/display/FREES/Merge+and+UnMerge+cells+-+Excel+VBA
I know this question has been asked already but I can't seem to make what I find work for me.
I just want to take all the data starting in column A and going to column J from row 2 to whatever the end of the data might be and reverse the order(inverse the data)
I stumbled upon the the code below but it freezes and I don't want to have to make a selection.
Private Sub CommandButton2_Click()
Dim vTop As Variant
Dim vEnd As Variant
Dim iStart As Integer
Dim iEnd As Integer
Application.ScreenUpdating = False
iStart = 1
iEnd = Selection.Columns.Count
Do While iStart < iEnd
vTop = Selection.Columns(iStart)
vEnd = Selection.Columns(iEnd)
Selection.Columns(iEnd) = vTop
Selection.Columns(iStart) = vEnd
iStart = iStart + 1
iEnd = iEnd - 1
Loop
Application.ScreenUpdating = True
End Sub
To be clear, I want to make the last row the first row, and the last row the first row. This is a continuous block of data.
Cheers
before
after
Another version of the code - see if this works.
Private Sub CommandButton2_Click()
Dim v(), i As Long, j As Long, r As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With Range("A1").CurrentRegion
Set r = .Offset(1).Resize(.Rows.Count - 1)
End With
ReDim v(1 To r.Rows.Count, 1 To r.Columns.Count)
For i = 1 To r.Rows.Count
For j = 1 To r.Columns.Count
v(i, j) = r(r.Rows.Count - i + 1, j)
Next j
Next i
r = v
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
The code below copies the data in each column to column number 20 - current column index, and at the end of the For loop it deletes the original data that lies in Columns A:J.
Option Explicit
Private Sub CommandButton2_Click()
Dim LastRow As Long
Dim Col As Long
Dim ColStart As Long, ColEnd As Long
Application.ScreenUpdating = False
' Column A
ColStart = 1
' Column J
ColEnd = 10 ' Selection.Columns.Count
' modify "Sheet1" to your sheet's name
With Sheets("Sheet1")
For Col = ColStart To ColEnd
' find last row with data for current column
LastRow = .Cells(.Rows.Count, Col).End(xlUp).Row
' copy in reverse order to column 20 to 11
' copy current column to column 20-current column index
.Range(Cells(2, Col), Cells(LastRow, Col)).Copy .Range(Cells(2, 20 - Col), Cells(LastRow, 20 - Col))
Next Col
End With
' delete original data in column A:J
With Sheets("Sheet1")
.Columns("A:J").EntireColumn.Delete
End With
Application.ScreenUpdating = True
End Sub
Like so? This assumes a continuous block of data from A2 (the currentregion) so will extend beyond J if there is more data, but could be restricted
Private Sub CommandButton2_Click()
Dim v, i As Long, r As Range
Application.ScreenUpdating = False
With Range("A1").CurrentRegion
Set r = .Offset(1).Resize(.Rows.Count - 1)
End With
v = r
For i = 1 To r.Rows.Count
r.Rows(i).Cells = Application.Index(v, r.Rows.Count - i + 1, 0)
Next i
Application.ScreenUpdating = True
End Sub
The following code converts a table of values to a single column.
The problem is, with my table the number of rows in each column decreases by one for each successive column. Similar to the table shown below.
I am VERY new to writing code and only know the very basics. I copied a script found online to convert a range of values to a single column. The portion of code that I wrote to delete any blank cells is slowing the code tremendously. To convert around 250,000 points to a column is taking roughly 9 hours. I am hoping to reduce the processing time as this is a script I expect to use regularly.
Sub CombineColumns()
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim rng As Range
Dim iCol As Long
Dim lastCell As Long
Dim K As Long
K = 484
'set K equal to the number of data points that created the range
Set rng = ActiveCell.CurrentRegion
lastCell = rng.Columns(1).Rows.count + 1
For iCol = 2 To rng.Columns.count
Range(Cells(1, iCol), Cells(rng.Columns(iCol).Rows.count, iCol)).Cut
ActiveSheet.Paste Destination:=Cells(lastCell, 1)
lastCell = lastCell + rng.Columns(iCol).Rows.count
Next iCol
Dim z As Long
Dim m As Long
z = K ^ 2
For Row = z To 1 Step -1
If Cells(Row, 1) = 0 Then
Range("A" & Row).Delete Shift:=xlUp
Application.StatusBar = "Progress: " & Row & " of z: " & Format((z - Row) / z, "Percent")
DoEvents
End If
Next
Application.StatusBar = False
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Sample Table Structure
Because I gave errant information on where this should be posted.
The following code will do what you want nearly instantly.
I used arrays to limit the number of interactions with the worksheet.
Sub foo5()
Dim ws As Worksheet
Dim rng() As Variant
Dim oarr() As Variant
Dim i&, j&, k&
Set ws = ThisWorkbook.Worksheets("Sheet19") 'Change to your sheet
With ws
rng = .Range("A1", .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, .Cells(1, .Columns.Count).End(xlToLeft))).Value
ReDim oarr(1 To Application.WorksheetFunction.CountA(rng), 1 To 1)
k = 1
For i = LBound(rng, 1) To UBound(rng, 1)
For j = LBound(rng, 2) To UBound(rng, 2)
If rng(i, j) <> "" Then
oarr(k, 1) = rng(i, j)
k = k + 1
End If
Next j
Next i
.Range("A1", .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, .Cells(1, .Columns.Count).End(xlToLeft))).Clear
.Range("A1").Resize(UBound(oarr), 1).Value = oarr
End With
End Sub