I am trying to make a select column of cells all be positive. I created this macro and it is working....just taking awhile. It's been running for probably 5min now. Mind you I do have 200k rows of data for it to search through...Anyone else have this problem before or ideas for it to be faster for next time???
Sub Positive()
Dim Cel As Range
For Each Cel In Selection
If IsNumeric(Cel.Value) Then
Cel.Value = Abs(Cel.Value)
End If
Next Cel
End Sub
Give this a try and let me know how the performance is:
Option Explicit
Sub Positive()
Dim varArray As Variant
Dim lngRow As Long, lngColumn As Long
varArray = Selection.Value2
For lngRow = LBound(varArray, 1) To UBound(varArray, 1)
For lngColumn = LBound(varArray, 2) To UBound(varArray, 2)
If IsNumeric(varArray(lngRow, lngColumn)) Then
varArray(lngRow, lngColumn) = Abs(varArray(lngRow, lngColumn))
End If
Next lngColumn
Next lngRow
Selection.Value2 = varArray
End Sub
I think you can save the range to an array, then process the array and write it back to the range, not tested but should be close.
Dim myArr() As Variant
myArr = Range("A1:A10")
Dim iCount As Long
For iCount = LBound(myArr) To UBound(myArr)
myArr(iCount) = abs(myArr(iCount))
Next iCount
Range("A1:A10") = myArr
Related
This question is kind of complicated (I feel), so I will do my best to explain the problem.
Essentially what I want to do is move down each column in the range, adding each cell value up (getting the sum of the column) and then adding it to an array. However, when testing the values held in the array, it is always 0. Is there a better way to do this?
Here is my current code:
Dim sumHoldings(1 To 36) As Double
k = 1
For Each rep In repNames
If rep <> vbNullString Then
Worksheets(rep).Activate
Dim i As Integer
Dim sumHolder As Double
For i = 3 To 6
Columns(i).Select
For Each rangeCell In Selection
If rangeCell <> vbNullString Then
sumHolder = rangeCell.Value + sumHolder
Else:
sumHoldings(k) = sumHolder 'this current method will keep overwriting itself
k = k + 1
Exit For
End If
Next rangeCell
Next i
End If
Next rep
Heres a visual representation of what I am trying to do:
Any help is greatly appreciated, thank you!
This is what you need to do.
Option Explicit
Public Sub TestMe()
Dim myRng As Range
Dim myCell As Range
Dim myCol As Range
Dim arrResults As Variant
Dim dblSum As Double
Dim lngCounter As Long
Set myRng = Range("R17:T25")
ReDim arrResults(myRng.Columns.Count -1)
For Each myCol In myRng.Columns
dblSum = 0
For Each myCell In myCol.Cells
dblSum = dblSum + myCell
Next myCell
arrResults(lngCounter) = dblSum
lngCounter = lngCounter + 1
Next myCol
End Sub
The array arrResults would get the sum of each column. Make sure to edit Set myRng = Range("R17:T25") to something meaningful for you.
The code works exactly as you have described it - it takes each column in the range, using myRng.Columns and it iterates over it. Then it takes each cell in myCol.Cells and it iterates again. Thus, the complexity is O2.
The reason you are getting zeros is because your if statement is letting them store null cells into your array when there is nothing in them. just move the storing section to after all cells are summed up:
For Each rangeCell In Selection
If rangeCell <> vbNullString Then
sumHolder = rangeCell.Value + sumHolder
End If
Next rangeCell
sumHoldings(k) = sumHolder
k = k + 1
Next i
End If
All i want to do is to optimize my current delete row code.
At this stage this step take to much time.
Dim miesiac2 As Integer '--->current month
miesiac2 = Range("b1").Value
Dim LastRow As Long
LastRow = [A65536].End(xlUp).Row
For i = LastRow To 1 Step -1
If Cells(i, 1) = miesiac2 Then Rows(i & ":" & i).EntireRow.Delete
Next i
So... If column A equals current month then EntireRow.Delete
Any idea?
That's something I have built so far:
Option Explicit
Public Sub TestMe()
Application.ScreenUpdating = False
Dim miesiac2 As Long
Dim LastRow As Long
Dim i As Long
Dim rRange As Range
miesiac2 = Range("b1").Value
LastRow = [A65536].End(xlUp).Row 'xl2003
For i = LastRow To 1 Step -1
If Cells(i, 1) = miesiac2 Then
If rRange Is Nothing Then
Set rRange = Rows(i)
Else
Set rRange = Union(rRange, Rows(i))
End If
End If
Next i
If Not rRange Is Nothing Then rRange.Select
Application.ScreenUpdating = True
End Sub
It uses a Union and it selects the rows instead of deleting them. Its for visibility reasons, but you can fix it.
Furthermore, the 65K rows are only in Excel 2003, in later versions the rows are 1Mln+. Last but not least - do not use integer in Excel, its slow and dangerous.
This is what I could cook up in hurry
Sub delete_on_condition()
Dim wb_export As Workbook
Dim wb_export_sheet As Worksheet
Dim arr_raw_dump As Variant
Dim arr_final
Dim findcell As Range
Set wb_export = ThisWorkbook ' CHANGE IT IF REQURIED
Set wb_export_sheet = wb_export.Sheets(1) 'CHANGE IT IF REQUIRED
Dim ctr As Long
ctr = 0
With wb_export_sheet.Range("A1").CurrentRegion ' OR With wb_export_sheet.USEDRANGE
Do
Set findcell = .Find("SOME TEXT")
If ctr = 0 And findcell Is Nothing Then
MsgBox "No data found"
Exit Sub
End If
wb_export_sheet.Rows(findcell.Row).Delete
Set findcell = .Find("SOMETEXT")
ctr = ctr + 1
Loop While Not findcell Is Nothing
End With
End Sub
I know how to make two functions on each column (in this case TRIM and STRCONV to ProperCase
Dim arrData() As Variant
Dim arrReturnData() As Variant
Dim rng As Excel.Range
Dim lRows As Long
Dim lCols As Long
Dim i As Long, j As Long
Range("H2", Range("H2").End(xlDown)).Select
lRows = Selection.Rows.Count
lCols = Selection.Columns.Count
ReDim arrData(1 To lRows, 1 To lCols)
ReDim arrReturnData(1 To lRows, 1 To lCols)
Set rng = Selection
arrData = rng.Value
For j = 1 To lCols
For i = 1 To lRow
arrReturnData(i, j) = StrConv(Trim(arrData(i, j)), vbProperCase)
Next i
Next j
rng.Value = arrReturnData
Set rng = Nothing
Currently I'm trying to figure out how to add one more FOR which where I could gather more than one selection ranges for example:
Set myAnotherArray(0) = Range("H2", Range("H2").End(xlDown)).Select
Set myAnotherArray(1) = Range("J2", Range("J2").End(xlDown)).Select
For k = 1 To myAnotherArray.lenght
Because I'm copying and pasting whole script to make aciton on three columns. Tried already:
Dim Rng As Range
Dim Area As Range
Set Rng = Range("Range("H2", Range("H2").End(xlDown)).Select,Range("J2", Range("J2").End(xlDown)).Select")
For Each Area In Rng.Areas
Area.Font.Bold = True
Next Area
Even tried to Union range but I failed. Any sugesstions?
And as always... Thank you for your time!
I found a way you could use to perform work on those ranges, refer to the code below:
Sub DoSomethingWithRanges()
Dim m_Worksheet As Excel.Worksheet
Dim m_Columns() As Variant
Set m_Worksheet = ActiveSheet
' fill all your columns in here
m_Columns = Array(2, 3, 4)
For Each m_Column In m_Columns
' the area being used ranges from the second until the last row of your column
With m_Worksheet.Range(m_Worksheet.Cells(2, m_Column), m_Worksheet.Cells(m_Worksheet.UsedRange.Rows.Count, m_Column))
' do things with range
.Font.Bold = True
End With
Next m_Column
End Sub
In the variant array m_Columns you can add all the columns you want. Only downside is that in my example you have to use numbers to specify columns instead of "H". However, you don't have to worry about the row-indexes, since the area automatically ranges from the second to the last used row.
I need to delete spaces at the beginning, end of string and make string Proper Case.
I have found two scripts:
Sub Function01()
Dim arrData() As Variant
Dim arrReturnData() As Variant
Dim rng As Excel.Range
Dim lRows As Long
Dim lCols As Long
Dim i As Long, j As Long
Range("R1", Range("R1").End(xlDown)).Select
lRows = Selection.Rows.Count
lCols = Selection.Columns.Count
ReDim arrData(1 To lRows, 1 To lCols)
ReDim arrReturnData(1 To lRows, 1 To lCols)
Set rng = Selection
arrData = rng.Value
For j = 1 To lCols
For i = 1 To lRows
arrReturnData(i, j) = Trim(arrData(i, j))
///ADDING HERE(read below)
Next i
Next j
rng.Value = arrReturnData
Set rng = Nothing
End Sub
which is deleting spaces on string and another script:
Sub ChangeCase()
Dim Rng As Range
On Error Resume Next
Err.Clear
Application.EnableEvents = False
For Each Rng In Selection.SpecialCells(xlCellTypeConstants, _
xlTextValues).Cells
If Err.Number = 0 Then
Rng.Value = StrConv(Rng.Text, vbProperCase)
End If
Next Rng
Application.EnableEvents = True
End Sub
Which is making Proper Case of string. Those two scripts are working on ranges to select all not null cells in R column. I need to make function second script in the first one.
Adding this code in first script at (///ADDING HERE) point:
arrReturnData(i, j) = StrConv(arrData(i, j), vbProperCase)
Making my output in Proper Case but with spaces.
Could you guys suggest how to make two script functions in a stroke?
Thank you!
This will do the whole without loops:
Sub Function01()
Dim rng As Range
Set rng = Selection
rng.Value = rng.Parent.Evaluate("INDEX(PROPER(TRIM(" & rng.Address & ")),)")
End Sub
Before:
After:
I have a VBA Macro for excel to find duplicates. It works but it is specified to a certain column. I would like to search through column headers which are in the 1st row and find the header called "Email" (the best would be "Email*" as sometimes this header contains some other words after the "Email" word). I think this script doesn't adjust to the number of rows and it is limited to 65536 values. I would prefer to let this script adjust to the number of values in the column. I have a similar VBA macro which does the perfect job. I thought I would be able to use this macro as an example and amend the one which I am currently working on...however I failed. Could anyone help me to do the proper amendments to the first code?
VBA MACRO WHICH I WOULD LIKE TO AMEND:
Option Explicit
Sub DeleteDups()
Dim x As Long
Dim LastRow As Long
Sheets("test").Activate
LastRow = Range("A65536").End(xlUp).Row
For x = LastRow To 1 Step -1
If Application.WorksheetFunction.CountIf(Range("A1:A" & x), Range("A" & x).Text) > 1 Then
Range("A" & x).Interior.Color = RGB(255, 48, 48)
End If
Next x
End Sub
VBA MACRO WHICH WORKS FINE AND I WANTED TO USE AS AN EXAMPLE:
Function getAllColNum(ByVal rowNum As Long, ByVal searchString As Variant) As Object
Dim allColNum As Object
Dim i As Long
Dim j As Long
Dim width As Long
Set allColNum = CreateObject("Scripting.Dictionary")
colNum = 1
With ActiveSheet
width = .Cells(rowNum, .Columns.Count).End(xlToLeft).Column
For i = 1 To width
If InStr(UCase(Trim(.Cells(rowNum, i).Value)), UCase(Trim(searchString))) > 0 Then
allColNum.Add i, ""
End If '
Next i
End With
Set getAllColNum = allColNum
End Function
Sub GOOD_WORKS_No_Dots_at_End_of_Emails()
Dim strSearch As String
strSearch = "Email"
Dim colNum As Variant
Dim allColNum As Object
Sheets("Data").Activate
Dim LR As Long, i As Long
Set allColNum = getAllColNum(1, searchString)
For Each colNum In allColNum
LR = Cells(Rows.Count, colNum).End(xlUp).Row
For i = 1 To LR
With Range(Cells(i, colNum), Cells(i, colNum))
If Right(.Value, 1) = "." Then .Value = Left(.Value, Len(.Value) - 1)
End With
Next i
Next colNum
Sheets("Automation").Activate
MsgBox "No Dots at the end of email addresses - Done!"
End Sub
MY WORK SO FAR
Function getAllColNum(ByVal rowNum As Long, ByVal searchString As Variant) As Object
Dim allColNum As Object
Dim i As Long
Dim j As Long
Dim width As Long
Set allColNum = CreateObject("Scripting.Dictionary")
colNum = 1
With ActiveSheet
width = .Cells(rowNum, .Columns.Count).End(xlToLeft).Column
For i = 1 To width
If UCase(Trim(.Cells(rowNum, i).Value)) Like UCase(Trim(searchString)) Then
allColNum.Add i, ""
End If '
Next i
End With
Set getAllColNum = allColNum
End Function
Sub testing_testing()
Dim strSearch As String
strSearch = "Email"
Dim colNum As Variant
Dim allColNum As Object
Sheets("Data").Activate
Dim LR As Long, i As Long
Set allColNum = getAllColNum(1, searchString)
For Each colNum In allColNum
LR = Cells(Rows.Count, colNum).End(xlUp).Row
For i = 1 To LR
With Range(Cells(i, colNum), Cells(i, colNum))
If Application.WorksheetFunction.CountIf(Range("R1:A" & x), Range("R" & x).Text) > 1 Then
Range("A" & x).Interior.Color = RGB(255, 48, 48)
End With
End If
Next i
Next colNum
Sheets("Automation").Activate
MsgBox "Finiding duplicates - Done!"
End Sub
Seems to be more complicated and as I mentioned I have limited knowledge of VBA. However, I found a different script which might be easier to amend.
This macro finds the email address column and marks the whole column
Option Explicit
Sub GOOD_WORKS_Mark_Email_Duplicates()
Dim x As Long
Dim LastRow As Long
Sheets("test").Activate
LastRow = Range("A65536").End(xlUp).Row
For x = LastRow To 1 Step -1
If Application.WorksheetFunction.CountIf(Range("A1:A" & x), Range("A" & x).Text) > 1 Then
Range("A" & x).Interior.Color = RGB(255, 48, 48)
End If
Next x
MsgBox "Email duplicates has been marked - red cells. Check if there are any red cells in the Email column"
End Sub
This one finds duplicates using countif function (which is good to me. The only problem is that I have this macro as a button, where the range is specified
Sub Highlight_Duplicates(Values As Range)
Dim Cell
For Each Cell In Values
If WorksheetFunction.CountIf(Values, Cell.Value) > 1 Then
Cell.Interior.ColorIndex = 6
End If
Next Cell
End Sub
Then the action button:
Private Sub CommandButton1_Click()
Highlight_Duplicates (Sheets("Test").Range("C2:C92"))
End Sub
It is fine for me to run 1st macro and then the 2nd. However, I don't know how to get rid of Range in the action button. Any ideas?
In your getAllColNum function, change this:
If InStr(UCase(Trim(.Cells(rowNum, i).Value)), _
UCase(Trim(searchString))) > 0 Then
to this:
If UCase(Trim(.Cells(rowNum, i).Value)) Like UCase(Trim(searchString)) Then
and that will allow you to pass a wildcard header like "email" and get all matching columns.