Right now I am using a horribly inefficient way for a replacement function:
Dim Replacement As String
Dim rngRepVal As Object
Set rngRepVal = Sheets("data").Range(Cells(1, 3), Cells(intRowLast, 3))
Replacement = ActiveCell.Value
rngRepVal.Replace What:="123", Replacement:="ABC", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False
rngRepVal.Replace What:="234", Replacement:="ABC", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False
rngRepVal.Replace What:="456", Replacement:="DEF", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False
... [goes on for 50 lines]
Set rngRepVal = Nothing
I am wondering if this can be achieved with arrays. Something like:
Dim aWhat() As String
Dim aReplacement() As String
aWhat = Split("ABC|DEF|GHI|JKL", "|")
aReplacement = Split(Array("123", 456")|Array("789","1000"), "|") '<-not sure how to organise this
Essentially 123 & 456 get replaced by ABC, 789 & 1000 get replaced by DEF etc. in a replace loop> Any insights on how to organise the two arrays? Thanks!
Your Replace(s) are fine - its the cell by cell loop and selection that is inefficient. Try something like this for three replaces over the entire range at once.
Sub Recut()
Dim rng1 As Range
Set rng1 = Sheets("data").Range(Sheets("data").Cells(1, 3), Sheets("data").Cells(Rows.Count, 3).End(xlUp))
With rng1
.Replace What:="123", Replacement:="ABC", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False
.Replace What:="234", Replacement:="ABC", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False
.Replace What:="456", Replacement:="DEF", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False
End With
End Sub
I would try this:
aWhat=Split("ABC|ABC|DEF|DEF|GHI|GHI...","|")
aReplacement=Split("123|456|789|.....","|")
For i=1 to UBound(aWhat)
rngRepVal.Replace what:=aWhat[i], Replacement:=aReplacement[i], ....
Next i
Just make sure there's the same number of elements in both arrays.
I think found it, by accident:
Dim aOld() As Variant
Dim aNew() As Variant
Dim Group As Variant
Dim Word As Variant
Dim y As Long
aNew = Array("ABC", "DEF", "GHI", "JKL")
aOld = Array(Array("123", "456"), Array("789", "1000"))
With Range("A:A")
For Each Group In aOld
For Each Word In Group
.Replace What:=Word, Replacement:=aNew(y), LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False
Next
y = y + 1
Next
End With
Related
There are 3 values in array. Out of those, 1 value is not there in the column for which I'm filtering the data ("matang"). I want to know how should i make it skip if there is no result for that keyword. That means after filtering using that keyword, no results are displayed. I want to skip that keyword and move onto next element of array. I have tried On Error Resume Next. So any other option?
Dim Ar() As Variant
Ar() = Array("jumpsuit", "matang", "bikini")
Dim i As Variant
For Each i In Ar
Sheets("tops").Select
ActiveSheet.Range("B1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$D$1335").AutoFilter Field:=2, Criteria1:="*" & i & "*", Operator:=xlAnd
ActiveCell.Offset(0, 1).Range("A1").Select
Sheets("Sheet1").Select
Cells.Find(What:=i, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Range("A1").Select
Selection.Copy
Selection.End(xlUp).Select
Sheets("tops").Select
Do
ActiveCell.Offset(1, 0).Select
Loop While ActiveCell.EntireRow.Hidden = True
ActiveSheet.Paste
Try wrapping everything after your Autofilter in a test for no results:
If ActiveSheet.AutoFilter.Range.Columns(2).SpecialCells(xlCellTypeVisible).Count - 1 > 0 Then
ie:
Dim Ar() As Variant
Ar() = Array("jumpsuit", "matang", "bikini")
Dim i As Variant
For Each i In Ar
Sheets("tops").Select
ActiveSheet.Range("B1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$D$1335").AutoFilter Field:=2, Criteria1:="*" & i & "*", Operator:=xlAnd
If ActiveSheet.AutoFilter.Range.Columns(2).SpecialCells(xlCellTypeVisible).Count - 1 > 0 Then
ActiveCell.Offset(0, 1).Range("A1").Select
Sheets("Sheet1").Select
Cells.Find(What:=i, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Range("A1").Select
Selection.Copy
Selection.End(xlUp).Select
Sheets("tops").Select
Do
ActiveCell.Offset(1, 0).Select
Loop While ActiveCell.EntireRow.Hidden = True
ActiveSheet.Paste
End If
Next i
You could just add a CountIf bit of logic in there to test if the i'th element of the array exists in the range? And then jump past the section of code that makes changes if it doesnt exist (ie = 0)? In my example, i've used the term 'skip'. So like this....
Dim Ar() As Variant
Ar() = Array("jumpsuit", "matang", "bikini")
Dim i As Variant
For Each i In Ar
Sheets("tops").Select
ActiveSheet.Range("B1").Select
If Application.WorksheetFunction.CountIf(ActiveSheet.Range("$A$1:$D$1335"), i) = 0 Then
GoTo Skip
End If
Selection.AutoFilter
ActiveSheet.Range("$A$1:$D$1335").AutoFilter Field:=2, Criteria1:="*" & i & "*", Operator:=xlAnd
ActiveCell.Offset(0, 1).Range("A1").Select
Sheets("Sheet1").Select
Cells.Find(What:=i, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Range("A1").Select
Selection.Copy
Selection.End(xlUp).Select
Sheets("tops").Select
Do
ActiveCell.Offset(1, 0).Select
Loop While ActiveCell.EntireRow.Hidden = True
ActiveSheet.Paste
Then just put the 'skip:' term somewhere just before the next (I cant see it in your code, is it because this is just a section of a larger sub?)
Make a function that check a list with the wanted values after put them in a sheet.
Function checking(value as string)
Dim x as integer
Dim numWantedvalues as Integer
numWantedvalues = WorksheetFunction.CountA(ThisWorkbook.Sheets("Sheet2").Range("A:A"))
For x = 1 to numWantedvalues
If ThisWorkbook.Sheets("Sheet2").Range("A" & x) = value Then
checking = True
End If
Next x
end function
Then introduce the function in your code:
If checking(arValue) = True Then
'Actions that you want to do
End If
I would like to replace the values in column A:A using arrays:
Dim aValueNew() As String
Dim aValueOld() As String
aValueNew = Split("ABC,DEF,GHI", ",")
aValueOld = Split("123,456,789", ",")
123 needs to be replaced by ABC, 456 by DEF and so forth.
What is the most efficient way of doing this? I am struggling on how to include the Replace function in a loop and your help would be appreciated. Something like:
For i = 0 to i = 2
Range("A:A").Replace What:= aValueOld(i), Replacement:=aValueNew(i), LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False
Try this code:
For i = 0 to UBound(aValueOld)
Columns("A:A").Select
Selection.Replace What:= aValueOld(i), Replacement:=aValueNew(i), LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False
Note:
Your For statement was wrong
If count of values are the bound of array use UBound(<Array Name>)
You almost had it. You may find the documentation for For...Next helpful.
Dim i As Long
For i = 0 To 2
Range("A:A").Replace What:=aValueOld(i), Replacement:=aValueNew(i), _
LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False
Next
I have this:
column A
row1: str1;str2;str3
row2: str4;str5;str6
row3: str7;str8;str9
....................
rown: strn;strn;strn
The code below finds ";" character into the column A:
Range("A:A").Find(What:=";", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
I want to put all rows (from column A, containing semicolon character) into an array. I tried to use SET, like this:
dim r as Variant
Set r = Range("A:A").Find(What:=rngsearch, After:=ActiveCell, LookIn:=xlFormulas, LookAt:=_
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext,MatchCase:=False _
, SearchFormat:=False).Activate
...but doesn't work. It's run-time error '13', type mismatch
I need this array (containing all the cells with semicolon) because I want to extract the strings (from str1 to strn) and separate them in different rows.
Can anyone help me? Maybe someone has another idea how I can do this?
There are probably more efficient ways to do this, I would personally prefer to avoid referring to an entire column, but this should hopefully do what you are expecting:
Sub test()
Dim ws As Worksheet
Dim rng As Range
Dim cel As Range
Dim strTmp As String
Dim arrFinal As Variant
Set ws = Sheets("Sheet1")
Set rng = ws.Range("A:A")
' Loop through all cells in column A
For Each cel In rng.Cells
' Is there a semicolon character in the cell?
If InStr(1, cel.Value, ";") > 0 Then
' Add the cell value to strTmp and add a _
semicolon at the end to separate this _
row from the next row
strTmp = strTmp & cel.Value & ";"
End If
Next cel
' Split strTmp into an array
arrFinal = Split(strTmp, ";")
End Sub
The end result Is an array called arrFinal of all strings between the semicolon characters
I was referring to something like this:
Sub GetSemicolonData()
Dim rngCell As Excel.Range
Dim asValues() As String
Dim lngCount As Long
Dim x As Long
With Range("A1").CurrentRegion.Columns(1)
.AutoFilter field:=1, Criteria1:="*;*"
lngCount = .SpecialCells(xlCellTypeVisible).Count
If lngCount > 1 Then
x = 1
' exclude header row
ReDim asValues(1 To lngCount - 1)
For Each rngCell In .SpecialCells(xlCellTypeVisible)
If rngCell.Row > 1 Then
' load value into array
asValues(x) = rngCell.Value
x = x + 1
End If
Next rngCell
End If
End With
End Sub
You could also use a variation of Dave's approach that loads all the data into an array and processes that - it should be faster than cell by cell reads.
Below VBA code is to find text and delete row. But it is searching based on the whole sheet.
How to I make it to only search "specific column" with the text array listed and delete the rows that contain text.
Based on the below code, it is search the whole sheet which I do not want.
Sub DeleteSystemMessage()
Dim varList As Variant
Dim varQP As Variant
Dim lngarrCounter As Long
Dim rngFound As Range, rngToDelete As Range
Dim strFirstAddress As String
Application.ScreenUpdating = False
'delete system message
varList = VBA.Array("XXXXXX", vbTextCompare)
For lngarrCounter = LBound(varList) To UBound(varList)
With Sheet1.UsedRange
Set rngFound = .Find( _
What:=varList(lngarrCounter), _
Lookat:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not rngFound Is Nothing Then
strFirstAddress = rngFound.Address
If rngToDelete Is Nothing Then
Set rngToDelete = rngFound
Else
If Application.Intersect(rngToDelete, rngFound.EntireRow) Is Nothing Then
Set rngToDelete = Application.Union(rngToDelete, rngFound)
End If
End If
Set rngFound = .FindNext(After:=rngFound)
Do Until rngFound.Address = strFirstAddress
If Application.Intersect(rngToDelete, rngFound.EntireRow) Is Nothing Then
Set rngToDelete = Application.Union(rngToDelete, rngFound)
End If
Set rngFound = .FindNext(After:=rngFound)
Loop
End If
End With
Next lngarrCounter
If Not rngToDelete Is Nothing Then rngToDelete.EntireRow.Delete
Application.ScreenUpdating = True
End Sub
If you change your search code like this it will only search in the column "A".
Set rngFound = Sheets(1).Columns("A:A").Find( _
What:=varList(lngarrCounter), _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
I got file.txt structure like this:
"FIRST"
a1 b1 c1 d1
a2 b2 c2 c2
"SECOND"
e1 f1
e2 f2
"THIRD"
g1 h1
I got three sheets in my Excel file: "first", "second" and "third". How to populate this data into three sheets by VBA code?
I still think that reading a text file line per line is the best way to go.
You can load the entire file into an array and write conditions later.
Sub Read_text_File()
Dim oFSO As New FileSystemObject
Dim oFS
Dim sText as String
Dim vArray
Dim lCnt as Long
Set oFS = oFSO.OpenTextFile("c:\textfile.TXT")
Do Until oFS.AtEndOfStream
lCnt = lCnt + 1
sText = oFS.ReadLine
vArray(lCnt) = sText
Loop
End Sub
Then look through the array and do your stuff.
Or you could load the data in three separate arrays immediately, representing the three sheets.
This is entirely up to you.
Let me know if this was helpful.
Start recording a macro and open the txt file delimited by space. press ctrl + f and find First, Second and Third in three steps. copy your required range from the active workbook to your required workbook in respective sheets.
this will give you a recorded macro which you can restructure to make an automated code. Maybe i can post some code later. you will have to add lines of vba to read the line numbers of the cells used to find secon and third so that you know what range you have to copy.
1 question, number of columns in your file is as shown????
here is a code.
Sub Macro1()
Dim startRow As Integer
Dim endRow As Integer
Dim wb As Workbook
Workbooks.OpenText Filename:="D:\file.txt", Origin:=437, startRow:=1, _
DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter _
:=True, Tab:=True, Semicolon:=False, Comma:=False, Space:=True, Other _
:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), _
TrailingMinusNumbers:=True
Set wb = ActiveWorkbook
Cells.Find(What:="FIRST", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
startRow = ActiveCell.Row + 1
Cells.Find(What:="SECOND", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
endRow = ActiveCell.Row - 1
Range("A" & startRow & ":D" & endRow).Copy
ThisWorkbook.Activate
Sheets("Sheet1").Select
Range("A1").Select
ActiveSheet.Paste
startRow = endRow + 2
wb.Activate
Cells.Find(What:="THIRD", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
endRow = ActiveCell.Row - 1
Range("A" & startRow & ":D" & endRow).Copy
ThisWorkbook.Activate
Sheets("Sheet2").Select
Range("A1").Select
ActiveSheet.Paste
wb.Activate
startRow = endRow + 2
endRow = Range("A" & Rows.Count).End(xlUp).Row
Range("A" & startRow & ":D" & endRow).Copy
ThisWorkbook.Activate
Sheets("Sheet3").Select
Range("A1").Select
ActiveSheet.Paste
wb.Close (False)
End Sub