I use the code below to search and replace a part of a text in a string. It works fine for almost 97 % of the replacements but not when one string that is supposed to be replaced is identical with another part of the string. Is there a straightforward method to avoid this?
Sub Macro1()
Dim i As Integer
For i = 2 To Worksheets("table1").Range("A1").End(xlDown).Row
Worksheets("table1").Range("H:H").Replace What:=Worksheets("table2").Range("A" & i), Replacement:=Worksheets("table2").Range("B" & i), LookAt:= _
xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
Next i
End Sub
Important: The delimiter is not always ",". It can also be any combination blank space(s) with a comma. Examples:
", "
" ,"
" , "
This is what is called a False Positive. If the delimiter is going to be always , then split the string. Do the replace and then join them again.
Is this what you are trying? I have commented the code. If you still have questions then simply ask.
Option Explicit
'~~> This is the delimiter. Change as applicable
Private Const Delim As String = ","
Sub Sample()
Dim wsTblA As Worksheet
Dim wsTblB As Worksheet
Dim lRow As Long
Dim i As Long, j As Long
Dim ArTable1 As Variant
Dim ArTable2 As Variant
'~~> Change this to the relevant worksheet
Set wsTblA = Worksheets("Table2")
Set wsTblB = Worksheets("Table1")
'~~> Get the values in Col A and B from Sheet Table2 in an array
With wsTblA
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
ArTable2 = .Range("A2:B" & lRow).Value2
End With
'~~> Get the values in Col H from Sheet Table1 in an array
With wsTblB
lRow = .Range("H" & .Rows.Count).End(xlUp).Row
ArTable1 = .Range("H2:H" & lRow).Value2
End With
'~~> Loop through the array
For i = LBound(ArTable2) To UBound(ArTable2)
For j = LBound(ArTable1) To UBound(ArTable1)
'~~> Check if the search string is present
If InStr(1, ArTable1(j, 1), ArTable2(i, 1), vbTextCompare) Then
'~~> If it is present then attempt a replace
ArTable1(j, 1) = ReplaceText(ArTable1(j, 1), ArTable2(i, 1), ArTable2(i, 2))
End If
Next j
Next i
'~~> Write the array back to the worksheet
wsTblB.Range("H2").Resize(UBound(ArTable1), 1).Value = ArTable1
End Sub
'~~> Function to split the text and then compare. If exact match, then replace
Private Function ReplaceText(CellValue As Variant, ReplaceWhat As Variant, ReplaceWith As Variant) As String
Dim tmpAr As Variant
Dim ReplacedText As String
Dim k As Long
'~~> Split the test using the delimiter
tmpAr = Split(CellValue, Delim)
'~~> If exact match, then replace
For k = LBound(tmpAr) To UBound(tmpAr)
If UCase(Trim(tmpAr(k))) = UCase(Trim(ReplaceWhat)) Then
tmpAr(k) = ReplaceWith
End If
Next k
'~~> Rejoin using delimiter
ReplacedText = Join(tmpAr, Delim)
ReplaceText = ReplacedText
End Function
Sheets TABLE2
Sheets TABLE1
Sheets TABLE1 OUTPUT
EDIT
Thank you for your wonderful solution. Problem is the delimiter is not always ",". It can also be a blank space " ". Problem using a blank space as additional delimiter might be the case that each element of the string e. g. "4711 Text_A" always has a blank space after the first 4 chars. – D3merzel 44 mins ago
In that case, you can take another approach. The text can appear in 3 positions. At the begining (TEXT & Delim), in the middle (Delim & TEXT & Delim) and in the end (Delim & TEXT)
Can you try the below code. I have not extensively tested it. If you find a scenario where it doesn't work then share it, I will tweak the code.
Option Explicit
'~~> This is the delimiter. Change as applicable
Private Const Delim As String = " "
Sub Sample()
Dim wsTblA As Worksheet
Dim wsTblB As Worksheet
Dim lRow As Long
Dim i As Long, j As Long
Dim ArTable1 As Variant
Dim ArTable2 As Variant
'~~> Change this to the relevant worksheet
Set wsTblA = Worksheets("Table2")
Set wsTblB = Worksheets("Table1")
'~~> Get the values in Col A and B from Sheet Table2 in an array
With wsTblA
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
ArTable2 = .Range("A2:B" & lRow).Value2
End With
'~~> Get the values in Col H from Sheet Table1 in an array
With wsTblB
lRow = .Range("H" & .Rows.Count).End(xlUp).Row
ArTable1 = .Range("H2:H" & lRow).Value2
End With
'~~> Loop through the array
For i = LBound(ArTable2) To UBound(ArTable2)
For j = LBound(ArTable1) To UBound(ArTable1)
'~~> Check if the search string is present
If Left(ArTable1(j, 1), Len(ArTable2(i, 1) & Delim)) = ArTable2(i, 1) & Delim Then
ArTable1(j, 1) = Replace(ArTable1(j, 1), ArTable2(i, 1) & Delim, ArTable2(i, 2) & Delim)
ElseIf InStr(1, ArTable1(j, 1), Delim & ArTable2(i, 1) & Delim, vbTextCompare) Then
ArTable1(j, 1) = Replace(ArTable1(j, 1), Delim & ArTable2(i, 1) & Delim, Delim & ArTable2(i, 2) & Delim)
ElseIf Right(ArTable1(j, 1), Len(Delim & ArTable2(i, 1))) = Delim & ArTable2(i, 1) Then
ArTable1(j, 1) = Replace(ArTable1(j, 1), Delim & ArTable2(i, 1), Delim & ArTable2(i, 2))
End If
Next j
Next i
'~~> Write the array back to the worksheet
wsTblB.Range("H2").Resize(UBound(ArTable1), 1).Value = ArTable1
End Sub
Sheets TABLE2
Sheets TABLE1
Sheets TABLE1 OUTPUT
EDIT
The above code handles all the ranges in one go! But if the code is too overwhelming (which it should not be), the above code can be reduced to a function to handle say individual string. One can use this function to check if the replace is happening correctly using a single string. For example
Debug.Print SidRepcl("bbb b_ bb b__ ccc_ bb b_ ccc", "ccc_", "ccc", " ")
Output: bbb b_ bb b__ ccc bb b_ ccc
As I mentioned earlier, all my codes above are based on the below logic
Logic: The text can appear in 3 positions. At the begining (TEXT & Delim), in the middle (Delim & TEXT & Delim) and in the end (Delim & TEXT)
Option Explicit
Function SidRepcl(txt As String, srch As String, repl As String, Delim As String) As String
Dim i As Long
Dim RetVal As String: RetVal = txt
'~~> Check if the search string is present
If Left(txt, Len(srch & Delim)) = srch & Delim Then
RetVal = Replace(txt, srch & Delim, repl & Delim)
ElseIf InStr(1, txt, Delim & srch & Delim, vbTextCompare) Then
RetVal = Replace(txt, Delim & srch & Delim, Delim & repl & Delim)
ElseIf Right(txt, Len(Delim & srch)) = Delim & srch Then
RetVal = Replace(txt, Delim & srch, Delim & repl)
End If
SidRepcl = RetVal
End Function
Flexible solution with any combinations of blank space(s) with comma(ta)
As alternative to Siddharth 's approaches you could change the logic by
splitting the input text via the ►search string itself instead of applying punctuation delimiters like e.g. ", ", "," or " ";
checking the last character in the current token and the starting character in each following token to execute replacements.
The following (edited 2023-01-02) function solves the additional requirements in comment that
... the delimiter is not always ",". It can also be a blank space " ". Problem using a blank space as additional delimiter might be the case that each element of the string e. g. "4711 Text_A" always has a blank space after the first 4 chars
by checking only one right or left neighbour character to each contained search string for " " or "," (c.f. returned helper function result IsMatch = curEndChar Like "[ ,]" And nxtStartChar Like "[ ,]" as well as comments to function TMreplc()).
Note that the substitution logic doesn't focus only to these evident delimiters but will change input strings like e.g. "4711 TEXT_A" also to e.g. 4711 TEXT_A/1.
Function TMreplc(txt As String, srch As String, repl As String) As String
'a) special case: replace entire text if identical to search string
If txt = srch Then TMreplc = repl: Exit Function
'b) get tokens by splitting via "search string" itself
Dim tokens: tokens = Split(txt, srch)
Dim ub As Long: ub = UBound(tokens)
'c) remember penultimate item
Dim mem As String: If ub > 0 Then mem = tokens(ub - 1)
'd) check most right token for content
Dim chk As Boolean: chk = tokens(ub) = vbNullString
If chk And ub > 0 Then
tokens(ub - 1) = tokens(ub - 1) & IIf(Len(mem) = 0, srch, repl)
If ub = 1 And tokens(0) = vbNullString Then tokens(0) = repl
End If
'e) Check predecessing tokens for substitutability
Dim i As Long
For i = 0 To ub - IIf(chk, 2, 1) ' if no srch finding at all (ignores: 0 To -1)
tokens(i) = tokens(i) & IIf(IsMatch(tokens, i), repl, srch)
Next i
'f) return result string
TMreplc = Join(tokens, vbNullString)
End Function
Function IsMatch(tokens, ByVal idx) As Boolean
Dim curEndChar As String
curEndChar = Right(IIf(idx = 0 And Len(tokens(0)) = 0, " ", "") & tokens(idx), 1)
Dim nxtStartChar As String: nxtStartChar = Left(tokens(idx + 1), 1)
IsMatch = curEndChar Like "[ ,]" And nxtStartChar Like "[ ,]"
End Function
Output examples
History
My first incomplete attempt below tried to include the cited additional requirement by checking only the following character, but didn't take into account those cases where the search string included preceding characters in the current token. I leave this attempt for learning purposes. - See Siddharth 's helpful comments that pointed me in the right direction.
A. First incomplete try
Function replc(txt As String, srch As String, repl As String) As String
'a) split input text into tokens via srch delimiter
Dim tokens: tokens = Split(txt, srch)
Dim ub As Long: ub = UBound(tokens)
'b) check possible change in last search item
Dim chg As Boolean: chg = tokens(ub) = vbNullString
If chg Then tokens(ub - 1) = tokens(ub - 1) & repl
'c) modify tokens
Dim i As Long
For i = 0 To ub - IIf(chg, 2, 1)
Dim nxtStartChar As String: nxtStartChar = Left(tokens(i + 1), 1)
tokens(i) = IIf(nxtStartChar Like "[ ,]", tokens(i) & repl, tokens(i) & srch)
Next i
'd) return joined tokens
replc = Join(tokens, vbNullString)
End Function
Additional note
It might be instructive, too how I tried to solve the original question (originally without the need of a different delimiter than ", "). Note the 2nd argument in the Match() function passed as array of a single string value.
Function replc2(txt As String, srch As String, repl As String) As String
Dim tokens: tokens = Split(txt, ", ")
Dim mtch: mtch = Application.Match(tokens, Array(srch), 0)
Dim i As Long
For i = 1 To UBound(mtch)
If IsNumeric(mtch(i)) Then tokens(i - 1) = repl
Next i
replc2 = Join(tokens, ", ")
End Function
B. My second try (as of 2022-12-13) includes a helper function IsMatch, but failed on certain scenarios (e.g. if the input txt is 100% identical to the search string - see last edit on top of post); I include it only for comparison reasons to complete history:
Function replc(txt As String, srch As String, repl As String) As String
Dim tokens: tokens = Split(txt, srch)
Dim i As Long
Dim ub As Long: ub = UBound(tokens)
Dim chg As Boolean: chg = tokens(ub) = vbNullString
If chg Then tokens(ub - 1) = tokens(ub - 1) & repl
For i = 0 To ub - IIf(chg, 2, 1)
tokens(i) = tokens(i) & IIf(IsMatch(tokens, i), repl, srch)
Next i
replc = Join(tokens, vbNullString)
End Function
Function IsMatch() - see top of post
Replace in Delimited Strings
Main
Sub ReplaceData()
Const SRC_DELIMITER As String = ","
Const DST_DELIMITER As String = ", "
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Write the values from the source range to an array.
Dim sws As Worksheet: Set sws = wb.Sheets("Table2")
If sws.AutoFilterMode Then sws.AutoFilterMode = False ' turn off AutoFilter
Dim srg As Range
Set srg = sws.Range("A2:B" & sws.Cells(sws.Rows.Count, "A").End(xlUp).Row)
Dim Data(): Data = srg.Value
' Sort the array by length descending so that the longer strings
' are first matched to avoid finding shorter strings before longer ones.
BubbleSortDataByLen Data, 1, True
' Write the unique values from the array to a dictionary.
Dim dict As Object: Set dict = TwoColumnsToDictionary(Data, 1, 2)
' Write the values from the destination range to an array.
Dim dws As Worksheet: Set dws = wb.Sheets("Table1")
If dws.AutoFilterMode Then dws.AutoFilterMode = False ' turn off AutoFilter
Dim drg As Range
Set drg = dws.Range("H2", dws.Cells(dws.Rows.Count, "H").End(xlUp))
Data = drg.Value
' Replace.
ReplaceSingleColumnData Data, dict, SRC_DELIMITER, DST_DELIMITER
' Write back to the range.
drg.Value = Data
' Inform
MsgBox "Data replaced.", vbInformation
End Sub
Sort
Sub BubbleSortDataByLen( _
ByRef Data() As Variant, _
ByVal SortColumnIndex As Long, _
Optional ByVal Descending As Boolean = False)
Dim rLB As Long, rUB As Long: rLB = LBound(Data, 1): rUB = UBound(Data, 1)
Dim cLB As Long, cUB As Long: cLB = LBound(Data, 2): cUB = UBound(Data, 2)
Dim T, i As Long, j As Long, c As Long, IsNotsorted As Boolean
For i = rLB To rUB - 1
For j = rLB + 1 To rUB
If Descending Then
If Len(CStr(Data(i, SortColumnIndex))) < Len(CStr( _
Data(j, SortColumnIndex))) Then IsNotsorted = True
Else
If Len(CStr(Data(i, SortColumnIndex))) > Len(CStr( _
Data(j, SortColumnIndex))) Then IsNotsorted = True
End If
If IsNotsorted Then
For c = cLB To cUB
T = Data(i, c): Data(i, c) = Data(j, c): Data(j, c) = T
Next c
End If
Next j
Next i
End Sub
Dictionary
Function TwoColumnsToDictionary( _
Data() As Variant, _
ByVal KeyColumnIndex As Long, _
ByVal ItemColumnIndex As Long, _
Optional ByVal MatchCase As Boolean = False) _
As Object
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = IIf(MatchCase, vbBinaryCompare, vbTextCompare)
Dim r As Long, kStr As String
For r = LBound(Data, 1) To UBound(Data, 1)
kStr = CStr(Data(r, KeyColumnIndex))
If Len(kStr) > 0 Then ' exclude blanks
' Use the first occurrences if any duplicates (shouldn't be any).
If Not dict.Exists(kStr) Then
dict(kStr) = CStr(Data(r, ItemColumnIndex))
End If
End If
Next r
If dict.Count = 0 Then Exit Function
Set TwoColumnsToDictionary = dict
End Function
Replace
Sub ReplaceSingleColumnData( _
ByRef Data() As Variant, _
ByVal dict As Object, _
ByVal InDelimiter As String, _
ByVal OutDelimiter As String)
Dim r As Long, n As Long
Dim sStrings() As String, sStr As String
For r = LBound(Data, 1) To UBound(Data, 1)
sStr = CStr(Data(r, 1))
If Len(sStr) > 0 Then
sStrings = Split(sStr, InDelimiter)
For n = 0 To UBound(sStrings)
sStr = Application.Trim(sStrings(n)) ' reusing 'sStr'
If dict.Exists(sStr) Then
sStrings(n) = dict(sStr)
Else
sStrings(n) = sStr
End If
Next n
Data(r, 1) = Join(sStrings, OutDelimiter)
End If
Next r
End Sub
you may want to stick to the Range.Replace() approach as much as possible
Option Explicit
Sub Macro1()
Const delimiter As String = " "
With Worksheets("table2") ' reference the find&replace sheet
Dim findRng As Range
Set findRng = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)) ' set the range in referenced sheet from column A row 2 down to last not empty row
End With
With Worksheets("table1") ' reference the data sheet
With .Range("H1", .Cells(.Rows.Count, "H").End(xlUp)) ' reference referenced sheet column "H" range from row 1 down to last not empty row
'-----------
'normalize the referenced range values to:
' - start with the delimiter
' - end with delimiter
' - only single spaces
Dim cel As Range
For Each cel In .Cells
cel.Value = delimiter & WorksheetFunction.Trim(cel.Value) & delimiter
Next
.Replace what:=" " & delimiter, replacement:=delimiter, lookat:=xlPart
.Replace what:=delimiter & " ", replacement:=delimiter, lookat:=xlPart
'-----------
' do the replacement
For Each cel In findRng
.Replace what:=cel.Value & delimiter, replacement:=cel.Offset(, 1) & delimiter, _
lookat:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Next
' un-normalize the references range
' - remove leading delimiters
' - remove trailing delimiters
For Each cel In .Cells
cel.Value = Mid$(cel.Value, 2, Len(cel.Value) - 2)
Next
End With
End With
End Sub
Where you only have to set the needed delimiter in Const delimiter As String = " "
Of course, should you suffer from speed issues, you can switch to a "range to array" approach.
First by acting on the "normalize" and "un-normalize" code sections, only
If necessary, acting on the "do the replacement" section, too
For simplicity, this should work
Sub Macro1()
Dim i As Integer
Dim rng As Range
Set rng = Application.Intersect(Worksheets("table1").Range("H:H"), Worksheets("table1").UsedRange)
endDel = ", , ,,,"
For Each cell1 In rng
cell1.Value = cell1.Value & endDel
Next cell1
For i = 2 To Worksheets("table1").Range("A1").End(xlDown).Row
Worksheets("table1").Range("H:H").Replace What:=Worksheets("table2").Range("A" & i) & " ", _
Replacement:=Worksheets("table2").Range("B" & i) & " ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False ', FormulaVersion:=xlReplaceFormula2
Worksheets("table1").Range("H:H").Replace What:=Worksheets("table2").Range("A" & i) & ",", _
Replacement:=Worksheets("table2").Range("B" & i) & ",", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False ', FormulaVersion:=xlReplaceFormula2
Next i
rng.Replace What:=endDel, _
Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False ', FormulaVersion:=xlReplaceFormula2
End Sub
If you have multiple delimiters, I assume they don't really matter and the string doesn't need to be completely identical apart from the replacements. Assuming that, the easiest way would be just to replace all the possible delimiters, with just one. You can then easily split the string, test each individually then recombine for a standardised string.
Example code uses Split(", # ,# , ", "#") with a delimiter that is not , for ease
Sub Blah()
Debug.Print Replacement("A, B , d,e,f,g , h", "e", "G")
End Sub
Function Replacement(strInput As String, ToFind As String, ToReplace As String) As String
Dim i As Long
Dim DelimArray() As String: DelimArray = Split(", # ,# , ", "#")
For i = LBound(DelimArray) To UBound(DelimArray)
strInput = Replace(strInput, DelimArray(i), ",")
Next i
Dim TextArray() As String: TextArray = Split(strInput, ",")
For i = LBound(TextArray) To UBound(TextArray)
If TextArray(i) = ToFind Then TextArray(i) = ToReplace
Next i
Replacement = Join(TextArray, ",")
End Function
Problem: The Range.Replace method (Excel) generates unreliable results under the following conditions:
The strings to be replaced are also part of other strings.
Strings in the target range have multiple delimiters.
The strings to be replaced contain one or more of the delimiters.
Data:
Old (What)
New (Replacement)
4711 TEXT_A
4711 TEXT_A/1
4710 TEXT_B
4710 TEXT_B/1
String
4711 TEXT_A 4710 TEXT_B 4711 TEXT_AA,4710 TEXT_BB , 4711 TEXT_A , 4710 TEXT_B,4711 TEXT_AA, 4710 TEXT_BB, 4711 TEXT_A,4710 TEXT_B, 4711 TEXT_AA, 4710 TEXT_BB
The string above presents all the conditions previously mentioned:
Solution Proposed:
This problem can be solved using the Range_Replace_With_MultiDelimiters procedure:
Syntax
Range_Replace_With_MultiDelimiters (rTarget, aDelimiters, aOldNew, [blIncludeFormulas])
Parameters
Remarks
Delimiters that contain other delimiters must be placed in the array before the delimiters it contains, e.g.:
Variables:
Method:
1 - Mask all sOld strings to be replaced: As the strings to be replaced may contain one or more of the delimiters; when we try to standardize the delimiters, the sOld strings contained in the target strings will be affected, particularly when the delimiter is {space} therefore we need to modify (Mask) the sOld strings before standardizing the delimiters.
To do this we define a one-character constant to be used as a Mask Character:
Const kMsk As String = "‡"
This character must not be present in the rTarget range, nor in any sNew string.
The sOld will be masked using the format ‡i‡, where i (position of sOld in the aOldNew array) is wrapped with the Mask Character ‡.
2 - Standardize the Delimiters: Define a one-character constants to be used as Standard Delimiter:
Const kChr As String = "§" '(ASCII code 167)
This character must not be present in the rTarget range, nor in any sNew string.
Then convert all delimiters to a Standard Delimiter Index using the format §i§, where i (position of the delimiter in the array) is wrapped by the Standard Delimiter §.
This is the standardizing formula:
= "§" & SUBSTITUTE( … SUBSTITUTE( rTarget, aDelimiters(1), "§1§" ) … , aDelimiters(n), "§n§") & "§"
After the entire replacement process is completed, all delimiters will be reset to their original value. This is the reset formula:
= SUBSTITUTE(SUBSTITUTE( … SUBSTITUTE( rTarget, "§1§", aDelimiters(1) ), … , "§n§", aDelimiters(n) ), "§", TEXT(,) )
These formulas will be created by the function: Range_Replace_ƒDelimiters_Formula and applied to the rTarget using the Application.Evaluate method (Excel).
3 - Replace masked sOld strings with sNew string: Before replacing the masked sOld strings with the corresponding sNew string, we need to wrap both masked sOld strings and the sNew strings with the Standard Delimiter constant previously defined:
sOld = kChr & kMsk & lIdx & kMsk & kChr '[kMsk & lIdx & kMsk] is masked sOld
sNew = kChr & aOldNew(lIdx, 2) & kChr
4 - Replace Mask strings with sOld string: Notice that as we wrapped the masked sOld string before replacing when the sOld string was contained in another string it was not replaced as it did not match the wrapped masked sOld string, achieving the expected result. Now we need to replace back the remaining masked sOld strings with the original sOld strings where partial matches within a larger string happened.
5 - Reset the delimiters: Replace the Standard Delimiter Index back to each original delimiter, using the formula mentioned (step 2). This step could also be used to reset the original delimiters to a standard delimiter, however, as the list of delimiters includes the {space} it’s advisable not doing it.
The results returned by the Range_Replace_With_MultiDelimiters procedure mathed the expected results:
Procedures:
Sub Search_and_Replace_Text()
Dim aDelimiters() As Variant
aDelimiters = Array( _
" , ", _
" ,", _
", ", _
",", _
" ")
Dim rTarget As Range, aOldNew() As Variant
Dim sWsh As String, sRng As String, sFml As String
Rem Set array with strings to be replaced (Old\New)
sWsh = "Table2"
sRng = "A:B"
With ThisWorkbook.Worksheets(sWsh).Range(sRng)
Rem Activate target worksheet (needed to apply the Application.Evaluate method)
Application.Goto .Cells(1), 1
With .Cells(2, 1).Resize(-1 + .Cells(.Rows.Count, 1).End(xlUp).Row, 2)
sFml = "=UNIQUE(FILTER(" & .Address _
& ",(" & .Columns(1).Address & "<>TEXT(,))))"
aOldNew = Application.Evaluate(sFml)
End With: End With
Rem Set range to apply the replace method
sWsh = "Table1"
sRng = "H:H"
With ThisWorkbook.Worksheets(sWsh).Range(sRng)
Set rTarget = Range(.Cells(2), .Cells(.Rows.Count).End(xlUp))
End With
Call Range_Replace_With_MultiDelimiters(rTarget, aDelimiters, aOldNew)
End Sub
Private Sub Range_Replace_With_MultiDelimiters( _
ByVal rTarget As Range, aDelimiters() As Variant, aOldNew() As Variant, _
Optional blIncludeFormulas As Boolean)
Rem Uncomment the lines the start with [':]
Rem to have in the Immediate Window a record of each step perfomed by the procedure
Const kChr As String = "§"
Const kMsk As String = "‡"
Dim rArea As Range
Dim sOld As String, sNew As String, lIdx As Long
Dim sFmlA As String, sFmlB As String
Dim sFml As String, aValues As Variant
Rem Built Delimiters Formula - Standardization & Reset
sFmlA = Range_Replace_ƒDelimiters_Formula(aDelimiters, kChr)
sFmlB = Range_Replace_ƒDelimiters_Formula(aDelimiters, kChr, True)
': Debug.Print vbLf; "Built Delimiters Formula - Standardization & Reset"
': Debug.Print "Standardization: "; vbLf; "sFmlA: "; sFmlA
': Debug.Print "Reset: "; vbLf; "sFmlB: "; sFmlB
Rem Exclude Formulas from Target range
If Not (blIncludeFormulas) Then
With rTarget
Set rTarget = Union(.SpecialCells(xlCellTypeBlanks), _
.SpecialCells(xlCellTypeConstants, 23))
End With: End If
With rTarget
Rem Activate target range worksheet (needed to apply the Application.Evaluate method)
Application.Goto .Worksheet.Cells(1), 1
For Each rArea In .Areas
With rArea
Rem Replace Old string To Mask string
': Debug.Print vbLf; "Replace Old To Mask"
': Debug.Print vbTab; "Old"; Tab(21); "New"
For lIdx = 1 To UBound(aOldNew)
sOld = aOldNew(lIdx, 1)
sNew = kMsk & lIdx & kMsk
': Debug.Print vbTab; sOld; Tab(21); sNew
.Replace What:=sOld, Replacement:=sNew, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
Next
Rem Standardize Delimiters
sFml = Replace(sFmlA, "#RNG", .Address(0, 0))
aValues = Application.Evaluate(sFml)
.Value2 = aValues
': Debug.Print vbLf; "Standardize Delimiters"
': Debug.Print "Fml: "; sFml
Rem Replace Mask string To New string
': Debug.Print vbLf; "Replace Mask To New"
': Debug.Print vbTab; "Old"; Tab(21); "New"
For lIdx = 1 To UBound(aOldNew)
sOld = kChr & kMsk & lIdx & kMsk & kChr
sNew = kChr & aOldNew(lIdx, 2) & kChr
': Debug.Print vbTab; sOld; Tab(21); sNew
.Replace What:=sOld, Replacement:=sNew, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
Next
Rem Replace Mask string To Old string
': Debug.Print vbLf; "Replace Mask To Old"
': Debug.Print vbTab; "Old"; Tab(21); "New"
For lIdx = 1 To UBound(aOldNew)
sOld = kMsk & lIdx & kMsk
sNew = aOldNew(lIdx, 1)
': Debug.Print vbTab; sOld; Tab(21); sNew
.Replace What:=sOld, Replacement:=sNew, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
Next
Rem Reset Delimiters
sFml = Replace(sFmlB, "#RNG", .Address(0, 0))
aValues = Application.Evaluate(sFml)
.Value2 = aValues
': Debug.Print vbLf; "Reset Delimiters"
': Debug.Print "Fml: "; sFml
End With: Next: End With
End Sub
Private Function Range_Replace_ƒDelimiters_Formula( _
aDelimiters() As Variant, sChr As String, Optional blReset As Boolean) As String
Dim sOld As String, sNew As String
Dim sFml As String
Dim vItem As Variant, bItem As Byte
Rem Separators
For Each vItem In aDelimiters
Rem Separators Old & New
bItem = 1 + bItem
sOld = IIf(blReset, sChr & bItem & sChr, vItem)
sNew = IIf(blReset, vItem, sChr & bItem & sChr)
Rem Built Formula - Delimiters Array
Select Case bItem
Case 1: sFml = "SUBSTITUTE(#RNG,""" & sOld & """,""" & sNew & """)"
Case Else: sFml = "SUBSTITUTE(" & sFml & ",""" & sOld & """,""" & sNew & """)"
End Select
Next
Rem Built Formula - Delimiters Character
Select Case blReset
Case True: sFml = "=SUBSTITUTE(" & sFml & ",""" & sChr & """,TEXT(,))"
Case Else: sFml = "= """ & sChr & """&" & sFml & "&""" & sChr & """"
End Select
Range_Replace_ƒDelimiters_Formula = sFml
End Function
Kindly see below code where it takes too much time run for more than 30rows in a range. (its similar to knapsack algorithm requirements)
let me try to explain below in detail,
Input Base sheet: Column A having values (For ex: 1555),
Column B having its Assignment value (A1),
Column C & D its filter value which will perform against input data sheet file.
Program working concept:
it takes first row(2) data from base sheet and apply filter (C2 & D2 value) in input data sheet (Column A & B respectively) then it checks value in column C and it find best sum to match the value (1555) or nearest to it and after it assigns value (which is A1) against those rows and repeats the same for next rows.
I have posted image below.
Kindly refer for Input Base sheet and Input Data sheet and
copy the codes in another workbook.
Run the macro, Choose Base sheet and the Data sheet. Program would run and assigns in Input data sheet. It runs super fast in lesser rows when I have more rows it gets hang/takes too hours to run.
Help me to where it can be speed up.
Appreciate your supports.
Thanks
input base sheet
input data sheet:
Sub sample1()
Dim lrow As Integer
Dim frow As Integer
Dim row As Integer
Dim ar As Variant
Dim aar As Variant
Dim Sol(), csol()
Dim arr As Variant
Dim pos As Integer
Dim arow() As Integer
Dim rng As Range
Dim rn As Range
Dim r As Range
Dim k As Integer
Dim itr As Integer
Dim path As String
Dim tm_base As Workbook
Dim tm_data As Workbook
Dim sh_base As Worksheet
Dim sh_data As Worksheet
Dim sh As Worksheet
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Set sh = ActiveSheet
ReDim arr(0)
arr(0) = ""
path = FileSelection("Input Base")
If path = "" Then Exit Sub
Set tm_base = Workbooks.Open(path)
path = FileSelection("Input Data")
If path = "" Then Exit Sub
Set tm_data = Workbooks.Open(path)
Set sh_base = tm_base.ActiveSheet
Set sh_data = tm_data.ActiveSheet
lrow = sh_data.Cells(Rows.Count, "A").End(xlUp).row
frow = sh_base.Cells(Rows.Count, "A").End(xlUp).row
SortMacro ActiveSheet, sh_base.Range("A2:A" & frow), sh_base.Range("A1:G" & frow), 2
SortMacro ActiveSheet, sh_data.Range("C2:C" & lrow), sh_data.Range("A1:G" & lrow), 2
For row = 2 To frow
If sh_base.Cells(row, "H") <> "Done" Then
itr = 1
sh_data.Range("A1:G" & lrow).AutoFilter Field:=4, Criteria1:="="
op2:
sh_data.Range("A1:G" & lrow).AutoFilter Field:=1, Criteria1:=sh_base.Cells(row, "C").Value
sh_data.Range("A1:G" & lrow).AutoFilter Field:=2, Criteria1:=sh_base.Cells(row, "D").Value
Set rn = Nothing
On Error Resume Next
Set rn = sh_data.Range("C2:C" & lrow).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rn Is Nothing Then
ReDim ar(0)
ReDim arow(0)
k = 1
For Each r In rn
ReDim Preserve arow(k)
ReDim Preserve ar(k)
ar(k) = r.Value
arow(k) = r.row
k = k + 1
Next
ReDim Sol(LBound(ar) To UBound(ar))
ReDim csol(LBound(ar) To UBound(ar))
limsum = sh_base.Cells(row, "A").Value
For i = LBound(ar) To UBound(ar)
If ar(i) > limsum Then
ar(i) = -1
End If
Next
maxsum = 0
findsum ar, Sol, csol, maxsum, limsum, UBound(ar), UBound(ar)
ss = ""
For i = 1 To Sol(0)
'ss = ss & sep & ar(sol(i))
'sep = ","
If Not arr(UBound(arr)) = "" Then
ReDim Preserve arr(UBound(arr) + 1)
End If
arr(UBound(arr)) = ar(Sol(i))
Next i
'MsgBox ss & " sum =" & maxsum
For j = LBound(arr) To UBound(arr)
pos = Application.Match(arr(j), ar, False)
If ar(pos - 1) > 0 Then
ar(pos - 1) = -1
End If
pos = arow(pos - 1)
If sh.Range("B1") = "Option 01" Then
sh_data.Cells(pos, "D") = sh_base.Cells(row, "B").Value
Else
sh_data.Cells(pos, "D") = sh_base.Cells(row, "B").Value & " " & Format(itr, "00")
End If
Next
ReDim arr(0)
arr(0) = ""
sh_base.Cells(row, "H") = "Done"
If sh.Range("B1") = "Option 02" Then
sh_data.Range("A1:G" & lrow).AutoFilter Field:=4, Criteria1:="="
Set rng = sh_data.Range("A1:A" & lrow).SpecialCells(xlCellTypeVisible)
If rng.Cells.Count > 1 Then
itr = itr + 1
GoTo op2
End If
End If
End If
sh_data.Range("A1:G" & frow).AutoFilter Field:=1
sh_data.Range("A1:G" & frow).AutoFilter Field:=2
sh_data.Range("A1:G" & lrow).AutoFilter Field:=4
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Sub findsum(ByVal a, ByRef Sol, ByRef csol, ByRef maxsum, ByRef limsum, si, maxcount, Optional s = 0, Optional lvl = 1, Optional dif = 100000, Optional minuscount = 0, Optional tsol, Optional j = 0)
' recursive sub
For i = LBound(a) To si
If a(i) > 0 Then
If s + a(i) > limsum Then findsum a, Sol, csol, maxsum, limsum, i - 1, maxcount, s, lvl + 1, dif, minuscount, tsol
s = s + a(i)
csol(lvl) = i
If s <= limsum Then
If s > maxsum Then ' we found a sum greater than current max we save it
maxsum = s
Sol(0) = lvl
For j = 1 To lvl
Sol(j) = csol(j)
Next j
End If
If i > LBound(a) Then ' pick another number
findsum a, Sol, csol, maxsum, limsum, i - 1, maxcount, s, lvl + 1, dif, minuscount, tsol
End If
End If
s = s - a(i)
If maxsum = limsum Then Exit For 'exit if exact match
End If
Next i
End Sub
Sub SortMacro(ws As Worksheet, rn As Range, rng As Range, ord As Integer)
ws.Sort.SortFields.Clear
ws.Sort.SortFields.Add Key:=rn, _
SortOn:=xlSortOnValues, Order:=ord, DataOption:=xlSortNormal
With ws.Sort
.SetRange rng
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Function FileSelection(file As String)
Dim path As String
Dim st As String
Dim i As Integer
Dim j As Integer
FileSelection = ""
With Application.FileDialog(3)
.title = "Select the " & file & " file"
.AllowMultiSelect = False
.InitialFileName = st
.Show
If .SelectedItems.Count = 0 Then
MsgBox "You didn't select the file!", vbExclamation, "Canceled"
Exit Function
Else
FileSelection = .SelectedItems(1)
End If
End With
End Function
You can't. I ran it. With 20 base data points and 100 data points you already have sub findsum called 79 million times. It's a combinatorial explosion and no amount of code tweaking will fix that. You'll have to find a better algorithm.
In the function 1 represents Col"1" and 2 represents Col"2".
When this function does not find any relevant strings from cater to Col"1" it stops.
I am trying to add a condition that if Col"1" strings are not matched with cater strings then there are strings with the name of "Permanent" in the Col"1" so the function will go for the "Permanent" along with the Condit, 2.
If string matches then function will work.
Original function
Public Function GetRowNo_ByCaterAndCondit(Cater As String, Condit As String) As Long
GetRowNo_ByCaterAndCondit = usedfunctions.GetRowNoTwoColumns( _
ThisWorkbook.Sheets("Sheet1"), Cater, 1, Condit, 2)
End Function
I tried this.
Public Function GetRowNo_ByCaterAndCondit(Permanent as string, Cater As String, Condit As String) As Long
If GetRowNo_ByCaterAndCondit = usedfunctions.GetRowNoTwoColumns( _
ThisWorkbook.Sheets("Sheet1"), Cater, 1, Condit, 2)
'if not macthed these Cater, 1 then
GetRowNo_ByCaterAndCondit = usedfunctions.GetRowNoTwoColumns( _
ThisWorkbook.Sheets("Sheet1"), permanent, 1, Condit, 2)
End if
End Function
Here is the GetRowNoSearchTwoColumns function:
Public Function GetRowNoSearchTwoColumns(Sht As Worksheet, _
StringToFind1 As String, ColumnNumber1 As Integer, _
StringToFind2 As String, ColumnNumber2 As Integer) As Long
On Error GoTo GetRowNoSearchTwoColumns_CleanUp_ErrorCheck
Dim OldReferenceStyle As XlReferenceStyle
Dim SheetUsedRange As Range
Dim LastRow As Long
Dim LastCol As Integer
Dim CompleteRange As Range
Dim StrFormula As String
OldReferenceStyle = Application.ReferenceStyle
Application.ReferenceStyle = xlR1C1
' Avoid problems if first row is empty, or first N rows (same problem with columns too)
Set SheetUsedRange = Sht.UsedRange
LastRow = SheetUsedRange.Row + SheetUsedRange.Rows.Count - 1
LastCol = SheetUsedRange.Column + SheetUsedRange.Columns.Count - 1
Set CompleteRange = Sht.Range(Sht.Cells(1, 1), Sht.Cells(LastRow, LastCol))
StrFormula = "=MATCH(""" & StringToFind1 & """&""" & StringToFind2 & """," & _
"'" & Sht.Name & "'!" & CompleteRange.Columns(ColumnNumber1).Address(ReferenceStyle:=xlR1C1) & "&" & _
"'" & Sht.Name & "'!" & CompleteRange.Columns(ColumnNumber2).Address(ReferenceStyle:=xlR1C1) & ",0)"
GetRowNoSearchTwoColumns = Application.Evaluate(StrFormula)
GetRowNoSearchTwoColumns_CleanUp_ErrorCheck:
' CleanUp
Application.ReferenceStyle = OldReferenceStyle
Set SheetUsedRange = Nothing
Set CompleteRange = Nothing
If Err.Number <> 0 Then
GetRowNoSearchTwoColumns = 0
End If
End Function
Try this out:
Public Function GetRowNo_ByCaterAndCondit(Permanent As String, Cater As String, _
Condit As String) As Long
Dim res, ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
res = usedfunctions.GetRowNoSearchTwoColumns(ws, Cater, 1, Condit, 2)
'if no match `res` will be zero - try again with `Permanent`
If res = 0 Then
res = usedfunctions.GetRowNoSearchTwoColumns(ws, Permanent, 1, Condit, 2)
End If
GetRowNo_ByCaterAndCondit = res
End Function
'Match two values in specific columns on a sheet and return the row number
' Return zero if no match
Public Function GetRowNoSearchTwoColumns(Sht As Worksheet, _
StringToFind1 As String, ColumnNumber1 As Long, _
StringToFind2 As String, ColumnNumber2 As Long) As Long
Dim f As String, res, lrow As Long
'get last-used row for each column and use the max value
lrow = Application.Max(Sht.Cells(Rows.Count, ColumnNumber1).End(xlUp).Row, _
Sht.Cells(Rows.Count, ColumnNumber2).End(xlUp).Row)
f = "=MATCH(""<v1>""&""<v2>"",<addr1>&<addr2>,0)"
f = Replace(f, "<v1>", StringToFind1)
f = Replace(f, "<v2>", StringToFind2)
f = Replace(f, "<addr1>", Sht.Cells(1, ColumnNumber1).Resize(lrow).Address(0, 0))
f = Replace(f, "<addr2>", Sht.Cells(1, ColumnNumber2).Resize(lrow).Address(0, 0))
Debug.Print f
res = Sht.Evaluate(f) 'Use the WorkSheet.Evaluate form (cleaner as you don't need
' to include the sheet name. Also no need to use R1C1 here.
GetRowNoSearchTwoColumns = IIf(IsError(res), 0, CLng(res)) 'return zero if no match
End Function
I have different test dates and times that can be up to about 100 tests each time point. I received the data that was only a single column that consists of thousands of rows, which should have been delivered in a matrix type grid.
I have only copied a sample, which has 6 time points and up to 4 tests each. I need Excel to "recognize" when there is only a date/time in a cell, then copy that cell to the next date/time to paste in a new sheet and column.
Eventually, I was hoping to also have the Title of the test separated from the results. However, if this is not plausible without knowing the name of every test, I can skip it. This is the data I start with:
Title
01/02/2010 0:03
Ounces: 10.87
Concentration: 6.89 (L)
Expiration Date: 11/2/2019 5:47:00
01/06/2011 2:06
Ounces: 18.09
Concentration: 10.7 (H)
Expiration Date: 11/2/2019 5:47:00
Other: Resampled
01/06/2011 2:06
Ounces: 12.87
Concentration: 10.9 (H)
Expiration Date: 11/2/2019 5:47:00
Other: 2nd Sample
09/15/2012 7:07
Ounces: 8.53
Concentration: 9.72
Expiration Date: 12/5/2019 4:45:00
05/02/2013 15:52
Ounces: 11.62
Concentration: 8.42
05/09/2017 1:45
Ounces: 9.34
Concentration: 8.98
I created the following Excel VBA, but am still new at programming, especially loops within loops, so I could not figure out how to create the offset that is dynamic enough to both select the right cells, but to copy them over to a new column. I also have redundancy within the code.
Sub Transpose()
Dim dDate As Date
Dim NumberofTasks As Long
Dim x As Long
sSheet = ActiveSheet.Name
Sheets.Add
dSheet = ActiveSheet.Name
With Worksheets("Sheet1")
' All Data is in Column A
NumberofTasks = .Cells(.Rows.Count, "A").End(xlUp).Row
For x = 1 To NumberofTasks
Sheets(sSheet).Activate
If IsDate(.Range("A" & x).Value) Then '<-- check if current cell at Column A is Date
Range(Cells(x, 1), Cells(x, 1).Offset(4, 0)).Select
Selection.Copy
Sheets(dSheet).Activate
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
ActiveCell.Offset(1, 0).Select
End If
Next x
End With
End Sub
This is what I hoped would happen (but on a much larger scale):
However, the offset places another date in another cell with the current code. Thank you for any help you can provide me.
There are many ways to skin a cat. Here is one way using arrays which is much much faster than looping through the range
Worksheet:
I am for the sake of coding, assuming that the data is in Sheet1 and looks like below
Logic:
Store the data from the worksheet in an array; Let's call it InputArray
Create an output array for storing data; Let's call it OutputArray
Loop through InputArray and find the date and then find the rest of the records. store in OutputArray
direct the output from OutputArray to the relevant worksheet.
Code:
Option Explicit
Sub Sample()
Dim InputArray As Variant
Dim ws As Worksheet
Dim i As Long
Dim recCount As Long
Dim lRow As Long
Dim OutputArray() As String
'~~> Set relevant input sheet
Set ws = Sheet1
With ws
'~~> Find Last Row in Col A
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Store col A in array
InputArray = .Range("A1:A" & lRow).Value
'~~> Find Total number of records
For i = LBound(InputArray) To UBound(InputArray)
If IsDate(InputArray(i, 1)) Then recCount = recCount + 1
Next i
'~~> Create an array for output
ReDim OutputArray(1 To 5, 1 To recCount + 1)
recCount = 2
'~~> Fill Col A of output array
OutputArray(1, 1) = "Title"
OutputArray(2, 1) = "Ounces"
OutputArray(3, 1) = "Concentration"
OutputArray(4, 1) = "Expiration Date"
OutputArray(5, 1) = "Other"
'~~> Loop through input array
For i = UBound(InputArray) To LBound(InputArray) Step -1
If IsDate(InputArray(i, 1)) Then '< Check if date
OutputArray(1, recCount) = InputArray(i, 1)
'~~> Check for Ounces and store in array
If i + 1 < UBound(InputArray) + 1 Then _
If UCase(Left(Trim(InputArray(i + 1, 1)), 2)) = "OU" _
Then OutputArray(2, recCount) = Trim(Replace(InputArray(i + 1, 1), "Ounces:", ""))
'~~> Check for Concentration and store in array
If i + 2 < UBound(InputArray) + 1 Then _
If UCase(Left(Trim(InputArray(i + 2, 1)), 2)) = "CO" _
Then OutputArray(3, recCount) = Trim(Replace(InputArray(i + 2, 1), "Concentration:", ""))
'~~> Check for Expiration Date and store in array
If i + 3 < UBound(InputArray) + 1 Then _
If UCase(Left(Trim(InputArray(i + 3, 1)), 2)) = "EX" _
Then OutputArray(4, recCount) = Trim(Replace(InputArray(i + 3, 1), "Expiration Date:", ""))
'~~> Check for Other and store in array
If i + 4 < UBound(InputArray) + 1 Then _
If UCase(Left(Trim(InputArray(i + 4, 1)), 2)) = "OT" _
Then OutputArray(5, recCount) = Trim(Replace(InputArray(i + 4, 1), "Other:", ""))
recCount = recCount + 1
End If
Next i
End With
'~~> Output it to relevant sheet
Sheet2.Range("A1").Resize(5, recCount - 1).Value = OutputArray
End Sub
Output:
I think here is better way to do it using Range.Find
Assuming the Data is in 1st Column of Sheet1 ie. Column A
In Demo the Expiration Date is not right, I have corrected that in the Code.
Try this code:
Sub TP()
Dim wk As Worksheet: Set wk = ThisWorkbook.Worksheets("Sheet1")
Dim lr As Long: lr = wk.Cells(wk.Rows.Count, "A").End(xlUp).row
Dim rng As Range
Dim i As Long
Dim j As Long
j = 4
For i = 3 To lr
Set rng = wk.Range(Cells(i, 1), Cells(i, 1).End(xlDown))
wk.Cells(2, j).Value = rng.Cells(1, 1).Value
Set fnd = rng.Find("Ounces")
If Not fnd Is Nothing Then wk.Cells(3, j).Value = Split(fnd.Value, ":")(1)
Set fnd = Nothing
Set fnd = rng.Find("Concentration")
If Not fnd Is Nothing Then wk.Cells(4, j).Value = Split(fnd.Value, ":")(1)
Set fnd = Nothing
Set fnd = rng.Find("Expiration")
If Not fnd Is Nothing Then wk.Cells(5, j).Value = Right(fnd.Value, Len(fnd.Value) - Len(Split(fnd.Value, ":")(0)) - 2)
Set fnd = Nothing
Set fnd = rng.Find("Other")
If Not fnd Is Nothing Then wk.Cells(6, j).Value = Split(fnd.Value, ":")(1)
Set fnd = Nothing
i = Cells(i, 1).End(xlDown).row + 1
j = j + 1
Next
End Sub
Demo:
May try something like this. Original code was modified and organized to complete the task intended. It takes cares if the other parameters of the test result are not organised in sequence as shown, blank row in between the parameters, no blank row between test results and or missing parameters. It only considers parameters found between rows of two test titles (date time). Takes only 0.5 seconds to process 200 test results from more than 1 K rows.
Option Explicit
Sub Transpose()
Dim dDate As Date
Dim NumberofTasks As Long
Dim x As Long, LastRow As Long, Xval As Variant
Dim srcWs As Worksheet, trgWs As Worksheet
Dim tm As Double
tm = Timer
Set srcWs = ThisWorkbook.ActiveSheet
Set trgWs = ThisWorkbook.Worksheets.Add
trgWs.Cells(1, 1).Value = "Title"
trgWs.Cells(2, 1).Value = "Ounces:"
trgWs.Cells(3, 1).Value = "Concentration:"
trgWs.Cells(4, 1).Value = "Expiration Date:"
trgWs.Cells(5, 1).Value = "Other:"
With srcWs
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
NumberofTasks = 0
x = 1
Do While x <= LastRow
Xval = .Cells(x, 1).Value
If IsDate(Xval) Then
NumberofTasks = NumberofTasks + 1
trgWs.Cells(1, NumberofTasks + 1).Value = .Range("A" & x).Value
ElseIf VarType(Xval) = vbString And NumberofTasks > 0 Then
Xval = Trim(LCase(Xval))
If InStr(1, Xval, "ounces:") > 0 Then
trgWs.Cells(2, NumberofTasks + 1).Value = Trim(Replace(Xval, "ounces:", ""))
ElseIf InStr(1, Xval, "concentration:") > 0 Then
trgWs.Cells(3, NumberofTasks + 1).Value = Trim(Replace(Xval, "concentration:", ""))
ElseIf InStr(1, Xval, "expiration date:") > 0 Then
trgWs.Cells(4, NumberofTasks + 1).Value = Trim(Replace(Xval, "expiration date:", ""))
ElseIf InStr(1, Xval, "other:") > 0 Then
trgWs.Cells(5, NumberofTasks + 1).Value = Trim(Replace(Xval, "other:", ""))
End If
End If
x = x + 1
Loop
End With
'Debug.Print "Seconds "; Timer - tm
End Sub
Tested to produce the result like
this
I am new to VBA and I could use a little bit of help for a program which I am struggling with for the past 3 days.
I have lot of data in a text file arranged as 3 columns. This data has to be parsed in an excel
The column 1 corresponds to the time, column 2 the variable and column 3 the value corresponding the variable .
The excel should parse the data such a way that column 1 has time, and column 2,3,4,5,6,7 the values corresponding to the variables in column 2 of the text file. and the values are in hex datei which has to be converted to decimal.
here is the code
Sub OpenText()
Dim MyFile As Variant
Dim TempWb As Workbook
Dim DestSh As Worksheet
Dim i As Long, p As Long, LimitRow As Long
Dim LastRow As Long
Dim LastRow2 As Long
p = 2
' Ask the user for the file name to open.
MyFile = Application.GetOpenFilename()
' Check for the Cancel button.
If MyFile = False Then Exit Sub
Application.ScreenUpdating = False
Set DestSh = ThisWorkbook.ActiveSheet
'Open the Text file with the OpenText method.
Workbooks.OpenText Filename:=MyFile, Origin:=xlWindows, _
StartRow:=1, DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _
Tab:=False, Semicolon:=False, Comma:=False, Space:=False, _
Other:=True, OtherChar _
:=";", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
1), Array(6, 1), Array(7, 1)), _
DecimalSeparator:=".", ThousandsSeparator:=" ", TrailingMinusNumbers:= _
True
Set TempWb = ActiveWorkbook
LimitRow = 1048576 'Version Excel 2010
LastRow = Range("A" & LimitRow).End(xlUp).Row
If LastRow > 0 Then
For i = 1 To LastRow
If i = 1 Then
Cells(p, 1).Value = Cells(i, 1).Value
End If
Test = Cells(i, 2).Value
If Test = "0x005B" Then Cells(p, 2).Value = Cells(i, 3).Value Else _
If Test = "0x003E" Then Cells(p, 3).Value = Cells(i, 4).Value Else _
If Test = "0x0033" Then Cells(p, 4).Value = Cells(i, 3).Value Else _
If Test = "0x0039" Then Cells(p, 5).Value = Cells(i, 3).Value Else _
If Test = "0x003B" Then Cells(p, 6).Value = Cells(i, 3).Value Else _
If Test = "0x003D" Then Cells(p, 7).Value = Cells(i, 3).Value Else _
Next
End If
End Sub
The text file looks somewhat like this
2017-03-23_11-48-32.8;0x003E;0x1000
2017-03-23_11-48-32.8;0x0033;0x01F4
2017-03-23_11-48-32.8;0x0039;0x6720
2017-03-23_11-48-32.8;0x003B;0x6720
2017-03-23_11-48-32.8;0x003D;0x0050
2017-03-23_11-48-32.8;0x005E;0x1234ABCD
2017-03-23_11-48-33.1;0x0033;0x01F4
2017-03-23_11-48-33.1;0x0039;0x6720
2017-03-23_11-48-33.1;0x003B;0x6720
2017-03-23_11-48-33.4;0x003E;0x1000
2017-03-23_11-48-33.4;0x0033;0x01F4
2017-03-23_11-48-33.4;0x0039;0x6720
2017-03-23_11-48-33.4;0x003B;0x6720
2017-03-23_11-48-33.4;0x003D;0x0050
2017-03-23_11-48-33.4;0x005E;0x1234ABCD
2017-03-23_11-48-33.7;0x0033;0x01F4
2017-03-23_11-48-33.7;0x0039;0x6720
2017-03-23_11-48-34.0;0x003E;0x1000
2017-03-23_11-48-34.0;0x0033;0x01F4
2017-03-23_11-48-34.0;0x0039;0x6720
2017-03-23_11-48-34.0;0x003B;0x6720
2017-03-23_11-48-34.0;0x003D;0x0050
2017-03-23_11-48-34.0;0x005E;0x1234ABCD
2017-03-23_11-48-34.3;0x0033;0x01F4
2017-03-23_11-48-34.3;0x0039;0x6720
2017-03-23_11-48-34.3;0x003B;0x6720
2017-03-23_11-48-34.6;0x003E;0x1000
2017-03-23_11-48-34.6;0x0033;0x01F4
2017-03-23_11-48-34.6;0x0039;0x6720
2017-03-23_11-48-34.6;0x003B;0x6720
2017-03-23_11-48-34.6;0x003D;0x0050
2017-03-23_11-48-34.6;0x005E;0x1234ABCD
2017-03-23_11-48-34.9;0x0033;0x01F4
2017-03-23_11-48-34.9;0x0039;0x6720
2017-03-23_11-48-34.9;0x003B;0x6720
2017-03-23_11-48-35.2;0x003E;0x1000
2017-03-23_11-48-35.2;0x0033;0x01F4
2017-03-23_11-48-35.2;0x0039;0x6720
2017-03-23_11-48-35.2;0x003B;0x6720
2017-03-23_11-48-35.2;0x003D;0x0050
2017-03-23_11-48-35.2;0x005E;0x1234ABCD
2017-03-23_11-48-35.5;0x0033;0x01F4
2017-03-23_11-48-35.5;0x0039;0x6720
2017-03-23_11-48-35.5;0x003B;0x6720
And also the excel gets created in a different worksheet instead of the current worksheet.
Thanks in advance
Hope this resolve ur problem
Public Sub Append_text()
Set fso = New FileSystemObject
FLoc = "Y:\Macro\Test" & Format(Now(), "HHMMSS") & ".txt"
Set Stream = fso.OpenTextFile(FLoc, ForAppending, True)
x = 1 'Hoping the start point
Do Until Sheet1.Cells(x, 1) = "" 'U can use the end of file code here for looping till last row
Stream.Write Sheet1.Cells(x, 1) & ";" & Sheet1.Cells(x, 2) & ";" & Sheet1.Cells(x, 3) & vbNewLine
x = x + 1
Loop
End Sub
Public Sub Read_text()
Sheet2.Activate
Set fso = New FileSystemObject
Fname = Application.GetOpenFilename
x = 1
y = 1
Set Stream = fso.OpenTextFile(Fname, ForReading, True)
Do While Not Stream.AtEndOfStream
Str_text = Stream.ReadLine 'Perform your actions
rdtext = Split(Str_text, ";")
Sheet2.Cells(x, y) = rdtext(0)
Sheet2.Cells(x, y + 1) = rdtext(1)
Sheet2.Cells(x, y + 2) = rdtext(2)
x = x + 1
y = 1
Loop
Stream.Close
End Sub
Not directly on point to the problem but does answer Parsing Text file using VBA.
This is an auto-detect routine. You can add it to a customized tab by temporarily substituting a Sub line with no parameter and adding that. Then replace the Sub line with the real line with the optional parameters.
If you don't specify any of the Optional delimiters, this looks at the first 5 lines of the file and checks for common delimiters. For example, if any of those lines contains more than 8 pipes it assumes pipe is the delimiter.
BEWARE OF THE 'AUTOMATIC COMMA-SPLIT' ISSUE IN THE COMMENT. That is an EXCEL quirk, not a problem with .TextToColumns. Excel "remembers" choices previously made in the Data tab when someone used Get External Data or Data Tools > Text to Columns and might automatically re-perform that parsing when the file is opened.
Option Explicit
Sub Parse_any_delimited( _
Optional ByVal dlm_pipe As Boolean = False, _
Optional ByVal dlm_semi As Boolean = False, _
Optional ByVal dlm_comma As Boolean = False, _
Optional ByVal dlm_tab As Boolean = False, _
Optional ByVal dlm_carat As Boolean = False, _
Optional ByVal dlm_char As String = "", _
Optional ByVal no_delim_popup As Boolean = True)
' *** WARNING !!! ***
'
' The FIRST record that EXCEL will see DURING AN IMPORT CANNOT CONTAIN
' COMMAS! IF IT DOES, it interprets those as DELIMITERS and AUTOMATICALLY
' does a field split there BEFORE running any code! The result is that
' when all text SHOULD wind up in Cell A1, instead it gets parsed into
' cells at each comma. Then the REAL PARSE routine can only parse what
' IS in the Column A cells.
'
' The "comma parse" UPON LOADING occurs BEFORE any macro runs!
Dim i As Integer
Dim check_data As Boolean
check_data = False
Dim dlm_other As Boolean
dlm_other = False
Dim rcrd As Variant
Dim leave_for As Boolean
Dim have_delim As Boolean
'1 ****
If dlm_pipe Then
dlm_other = True
dlm_char = "|"
have_delim = True
'2 ****
ElseIf dlm_carat Then
dlm_other = True
dlm_char = "^"
have_delim = True
'3 ****
ElseIf dlm_tab Or dlm_semi Or dlm_comma Then
have_delim = True
'4 ****
Else
For i = 1 To 5 'Check first 5 records for common delimiters
leave_for = True
rcrd = Cells(i, "A").Value
If Count_Characters(rcrd, "|") > 5 Then
dlm_other = True
dlm_char = "|"
ElseIf Count_Characters(rcrd, ";") > 5 Then
dlm_semi = True
ElseIf Count_Characters(rcrd, ",") > 10 Then
dlm_comma = True
ElseIf Count_Characters(rcrd, vbTab) > 4 Then
dlm_tab = True
ElseIf Count_Characters(rcrd, "^") > 5 Then
dlm_other = True
dlm_char = "^"
Else
leave_for = False
End If
'===============
If leave_for Then
have_delim = True
Exit For
Else
have_delim = False
End If
Next i
'5 ****
End If
If have_delim = False Then
' B2 is checked because in certain cases Excel will
' AUTOMATICALLY parse data delimited by | or semicolons.
' When that happens, THIS sub sees it as "No delimiter Can't Parse"
' even though it HAS BEEN parsed.
If Cells(2, "B").Value = "" And no_delim_popup Then
MsgBox ("CAN'T PARSE - NO DELIMITER FOUND")
End If
Exit Sub
End If
' Stops "There's already data here--continue?"
Application.DisplayAlerts = False
Columns("A:A").Select
Selection.TextToColumns _
Destination:=Range("A1"), _
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=dlm_tab, _
Semicolon:=dlm_semi, _
Comma:=dlm_comma, _
Space:=False, _
Other:=dlm_other, _
OtherChar:=dlm_char
Cells.Select
Selection.Columns.AutoFit
Range("A1").Select
Application.DisplayAlerts = True
' Sub Parse_any_delimited()
End Sub
Function Count_Characters( _
ByVal str As Variant, _
ByVal chr As Variant) _
As Long
Count_Characters = Len(str) - Len(Replace(str, chr, ""))
End Function