using VBA, how to remove the addidtional repeated characters at last

0
votes

I have multiple rows, I need to join with "@#" characters at end of every cell value, I am able add this characters but at the end it is printing extra characters(@#)

My excel file: From this excel file, I need to join the values by @# for each cell and feed into notepad

Excel File for Input

My output should be:(Actual and Expected)

Actual and Expected Output

Here Is my code:

sub join()
dim LRow as long
dim LCol as long
Dim str1 as string
Dim str2 as string
Dim ws1 As Worksheet
Set ws1 = ActiveWorkbook.Worksheets(1)
 plik = ThisWorkbook.Path & "\" & "BL2ASIS" & ws1.Name & ".txt"
 Open plik For Output As 2
With ws1
LRow = .Cells(.Rows.Count, 1).End(xlUp).Row
LCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
LCol = LCol - 2
slast = vbNullString


str2 = Join(Application.Transpose(Application.Transpose(.Cells(n, "A").Resize(1, 2).Value)), "")
str1 = str2 & Join(Application.Transpose(Application.Transpose(.Cells(n, "C").Resize(1, LCol).Value)), "@#") & "@#"
str1 = Replace(str1, "=", vbNullString)
str1 = Replace(str1, "@#@#", "@#")


Print #2, str1
End with

end sub
3
vbaexcelexcel-formula
Just noticed you are using Replace. And that is not working? – QHarr
is the problem where you add & "@#" after Join? Have you checked you don't end up somewhere with @#@#@# + ? – QHarr
I imagine it is because empty strings are still being concatenated with "@#"... Perhaps try checking the length of the string is more than 0 before adding the "@#" – Glitch_Doctor
@QHarr Yeah U r right, I used replace, but it works only for two characters(@#@#) then it replaces with one time(@#), if there is 4 times I feed this item(@#@#@#@#) then it replaces with one time(@#@#) – Antony Prince Peter
then that is your problem right there. – QHarr

3 Answers

1
votes

You could replace your line:

str1 = Replace(str1, "@#@#", "@#")

with:

Do Until Len(str1) = Len(Replace(str1, "@#@#", "@#"))
    str1 = Replace(str1, "@#@#", "@#")
Loop

which will keep applying the replace until there is no point in doing so (i.e. the length doesn't change)

EDIT

Sorry to alter an accepted answer, but I've noticed that you might want to keep instances of @#@# if they occur somewhere other than at the end of the row. If you do then the following would be better, as it only trims the right-most characters:

Do Until Right(str1, 4) <> "@#@#"
    str1 = Left(str1, Len(str1) - 2)
Loop
1
votes

The reason you are getting repeated characters is because you are joining empty array elements. An alternative to removing repeated delimiters is to use a UDF to only join non null values. Please see below for such a function.

Sub TestJoin()
    Dim r As Range: Set r = Worksheets("Sheet1").Range("B1:B12")
    Dim arr() As Variant
    arr = Application.Transpose(r)
    Debug.Print NonNullJoin(arr, "#") & "#"
End Sub

Function NonNullJoin(SourceArray() As Variant, Optional Delimiter As String = " ") As String
    On Error Resume Next
    Dim i As Long: For i = 0 To UBound(SourceArray)
        If CStr(SourceArray(i)) <> "" Then NonNullJoin = _
            IIf(NonNullJoin <> "", NonNullJoin & Delimiter & CStr(SourceArray(i)), CStr(SourceArray(i)))
    Next i
End Function
1
votes

Use regex to replace more than one instance.

Note:

  1. If you want to replace repeats only at the end of the string then change regex pattern to (@#){2,}$ . This will deal with 2 or more occurrences.
  2. If only worried about two occurrences at end, use (@#)\1$

Code:

Option Explicit

Sub TEST()
    Dim testString As String, pattern As String
    testString = "xxxxx@#@#"
    testString = RemoveChars(testString)
    Debug.Print testString
End Sub

Public Function RemoveChars(ByVal inputString As String) As String

    Dim regex As Object, tempString As String
    Set regex = CreateObject("VBScript.RegExp")

    With regex
        .Global = True
        .MultiLine = True
        .IgnoreCase = False
        .pattern = "(@#){2,}"
    End With

    If regex.TEST(inputString) Then
        RemoveChars = regex.Replace(inputString, "@#")
    Else
        RemoveChars = inputString
    End If

End Function