Excel VBA Two functions on one array - vba

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:

Related

A better way in VBA to remove a whole row if one cell contains one certain word?

I wrote the following code, which looks for 3 words in the column G and then in case, that one of those occurs it delete the whole row.
However, it is not so efficient(quick). I guess because of 3 If and ElseIf.
Does someone know a better way to do it?
Last = Workbooks("reportI.xlsm").Sheets("SII_I").Cells(Rows.Count, "G").End(xlUp).Row
For i = 2 To Last Step 1
If (Workbooks("reportI.xlsm").Sheets("SII_I").Cells(i, "G").Value) = "01NU SfG" Then
Workbooks("reportI.xlsm").Sheets("SII_I").Cells(i, "A").EntireRow.Delete
'
'with the word "01NU" in column G
ElseIf (Workbooks("reportI.xlsm").Sheets("SII_I").Cells(i, "G").Value) = "01NU" Then
Workbooks("reportI.xlsm").Sheets("SII_I").Cells(i, "A").EntireRow.Delete
'with the word "11G SfG" in column G
ElseIf (Workbooks("reportI.xlsm").Sheets("SII_I").Cells(i, "G").Value) = "11G SfG" Then
Cells(i, "A").EntireRow.Delete
End If
Debug.Print i
Next i
You can use just one if clause by using the OR operator.
If "A1"= "01NU OR "A1" = "SfG" OR "A1" = "11G SfG" Then
'delete row
Alternatively, you can get your macro to filter that column for the values 01NU, SfG, 11G SfG, and then delete all the filtered rows. This is definitely more faster.
Just replace range A1 by your required range.
Another solution:
Sub Demo()
Dim delItems As String
Dim rng As Range, searchRng As Range, cel As Range
Dim lastRow As Long
delItems = "01NU SfG,01NU,11G SfG" 'search items
With Workbooks("reportI.xlsm").Sheets("SII_I")
lastRow = .Cells(Rows.Count, "G").End(xlUp).Row
Set searchRng = .Range("G1:G" & lastRow)
For Each cel In searchRng
If InStr(1, delItems, cel.Value, vbTextCompare) Then
If rng Is Nothing Then
Set rng = .Rows(cel.Row)
Else
Set rng = Union(rng, .Rows(cel.Row))
End If
End If
Next cel
End With
rng.Delete
End Sub
The code would need a little alteration to fit your needs, but this answer is very robust and scalable.
For example:
Sub Sample()
Dim DeleteThese(3) As String, strg As String
Dim rng As Range
Dim Delim As String
Dim Last As Long
Dim ws As Worksheet
Set ws = Workbooks("reportI.xlsm").Sheets("SII_I")
Last = ws.Cells(Rows.Count, "G").End(xlUp).Row
Delim = "#"
DeleteThese(0) = "01NU SfG"
DeleteThese(1) = "01NU"
DeleteThese(2) = "11G SfG"
strg = Join(DeleteThese, Delim)
strg = Delim & strg
For i = 2 To Last Step 1
If InStr(1, strg, Delim & ws.Range("G" & i).Value & Delim, vbTextCompare) Then _
ws.Range("G" & i).EntireRow.Delete
Next i
End Sub

VBA Delete row 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

Excel VBA array of Selected Range

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.

VBA absolute macro taking forver

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

Need help trimming spaces out of column

I am trying to figure out how to loop through the first column of my worksheet and take out the spaces so I can use VLOOKUP. Not sure how to do it in VBA. Here is what I have:
I can't figure out why it does not go onto the next sheet now? I can't just cycle through all of the sheets since they are different.
Sub trima()
Dim x As Integer
Dim numrows As Long
numrows = Range("A1",Range("A1").End(xlDown)).Rows.Count
Range("A1").Select
For x = 1 To numrows
Application.WorksheetFunction.trim (ActiveCell)
ActiveCell.Offset(1, 0).Select
Next
End Sub
Here you go:
Sub TrimA()
Dim v
v = [transpose(transpose(trim(a1:index(a:a,match("",a:a,-1)))))]
[a1].Resize(UBound(v)) = v
End Sub
UPDATE
If you want to update multiple sheets, you can utilize the above like so:
Sub DoTrims()
Sheet1.Activate: TrimA
Sheet2.Activate: TrimA
'etc.
End If
The Trim function does not work like that.
Instead, try something like:
Sub trima()
Dim numrows As Long
Dim vItem as Variant
Dim i As Long
numrows = Range("A1",Range("A1").End(xlDown)).Rows.Count
Application.ScreenUpdating = False
With ActiveSheet
For i = 1 To numrows
vItem = .Range("A" & i)
If vItem <> vbNullString then .Range("A" & i) = Application.WorksheetFunction.Trim(vItem)
Next
End With
Application.ScreenUpdating = True
End Sub
The following code will loop through ALL worksheets in the Workbook and perform the same trim on values in Column A:
Sub trimA()
Dim ws As Excel.Worksheet
Dim i As Long, numrows As Long
Dim vItem As Variant
Application.ScreenUpdating = False
For Each ws In Worksheets
With ws
numrows = .Range("A1", .Range("A1").End(xlDown)).Rows.Count
For i = 1 To numrows
vItem = .Range("A" & i)
If vItem <> vbNullString Then .Range("A" & i) = Application.WorksheetFunction.Trim(vItem)
Next i
End With
Next
Application.ScreenUpdating = True
End Sub
Using the Range.TextToColumns method should quickly clear all cells containing leading/trailing spaces.
This procedure can quickly convert text-that-look-like-numbers to true numbers as well.
Dim c As Long
With Range("A1").CurrentRegion `<~~ set to the desired range of one or more columns
For c = 1 To .Columns.Count
.Columns(c).TextToColumns Destination:=.Columns(c), _
DataType:=xlFixedWidth, FieldInfo:=Array(0, 1)
Next c
End With
If the cells actually contain non-standard spacing like the non-breaking space (common on data copied from a web page) then other Range.Replace method should be added.