I have two strings like
str1= "[abc 1],[def 2],[ghi 3],[jkl 4],[mno 5]"
str2="[def 2],[mno 5]"
The strings in str2 [def 2],[mno 5] should be deleted or replaced with "" in str1. result will be
str1="[abc 1],[ghi 3],[jkl 4]"
I tried replace function but not working giving full string str1
strorg1 = Replace(str1, str2,"")
Try this (sorry for not being able to format as code by now)
Option Explicit
Sub Main()
Dim str1 As String, str2 As String
Dim str As Variant
str1 = "[abc 1],[def 2],[ghi 3],[jkl 4],[mno 5]"
str2 = "[def 2],[mno 5]"
str1 = "|" & str1 & "|"
For Each str In Split(str2, ",")
str1 = Replace(str1, str, "")
Next str
str1 = Replace(Replace(Replace(str1, ",,", ","), "|,", ""), ",|", "")
MsgBox str1
End Sub
This works i think:
Option Explicit
Sub gen()
Dim ReplaceList(1 To 5) As String
Dim str1 As String, strToReplace As Variant
Dim a() As String
Dim element As Long
str1 = "[abc 1],[def 2],[ghi 3],[jkl 4],[mno 5]"
ReplaceList(1) = "[def 2]"
ReplaceList(2) = "[mno 5]"
a = Split(str1, ",")
For element = UBound(a) To 0 Step -1
For Each strToReplace In ReplaceList
If a(element) = strToReplace Then
a(element) = ""
End If
Next
Next
str1 = Join(a)
Debug.Print str1
End Sub
edit, i don't have access to Access, I hope this works, if not it should set you on the right track.
Try this one :
Sub Macro1()
Dim str1 As String
Dim str2 As String
Dim strTemp As String
Dim strTemp2 As String
Dim strOut As String
str1 = "[abc 1],[def 2],[ghi 3],[jkl 4],[mno 5]"
str2 = "[def 2],[mno 5]"
strOut = str1
Do
strTemp = Application.WorksheetFunction.Search("]", str2)
strTemp2 = Mid(str2, 1, strTemp + 1)
strOut = Replace(strOut, strTemp2, "")
str2 = Replace(str2, strTemp2, "")
Loop Until str2 = ""
End Sub
It will parse your str2, cut pieces inside [] and remove it from str1 one by one.
The output is what you expected, using excel 2010.
Related
I've been trying to translate a word passed through the transFunc function and display the translated word in a MsgBox. When I try to run my code, I get an error saying Object doesn't support this property or method. I know it is messing up at the "cleanData = " line, but I can't figure out why. I've been trying for days now, so any help is greatly appreciated. Thank you so much!!!
Public Sub transFunc(Optional Word As String)
Dim IE As Object
Dim i As Long
Dim inputString As String
Dim outputString As String
Dim textToConvert As String
Dim resultData As String
Dim cleanData As Variant
Dim Url As String
Dim j As Integer
Set IE = CreateObject("InternetExplorer.application")
inputString = "auto"
outputString = "es"
textToConvert = Word
IE.Visible = True
Url = "https://translate.google.com/?sl=" & inputString & "&tl=" & outputString & "&text=" &
textToConvert & "&op=translate"
IE.navigate Url
Do Until IE.readyState = 4
DoEvents
Loop
Application.Wait (Now + TimeValue("0:00:5"))
Do Until IE.readyState = 4
DoEvents
Loop
replaceInput = IE.document.getElementById("result_box").innerHTML
splitInput = Replace(replaceInput, "</SPAN>", "")
cleanData = Split(splitInput, "<")
For j = LBound(cleanData) To UBound(cleanData)
resultData = resultData & Right(cleanData(j), Len(cleanData(j)) - InStr(cleanData(j), ">"))
Next j
MsgBox (resultData)
IE.Quit
End Sub
I would like to fetch image captured information ( Date & Time) after uploading image as attachment in access form. need assistance .
Got this to work.
Sub GetDatePictureTaken(strFolder, strFileName)
Dim strDate As String
Dim objShell, objFolder
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace(strFolder)
strDate = objFolder.GetDetailsOf(objFolder.ParseName(strFileName), 12)
strDate = CleanNonDisplayableCharacters(strDate)
Debug.Print strDate
End Sub
Function CleanNonDisplayableCharacters(strInput)
Dim strTemp As String, strChar As String, i As Integer
strTemp = ""
For i = 1 To Len(strInput)
strChar = Mid(strInput, i, 1)
If Asc(strChar) < 126 And Not Asc(strChar) = 63 Then
strTemp = strTemp & strChar
End If
Next
CleanNonDisplayableCharacters = strTemp
End Function
Resources:
Trying to use Shell object and FileSystemObject in VBScript for file manipulation
https://social.technet.microsoft.com/Forums/scriptcenter/en-US/3f220113-8b7c-4d32-9681-cdcc942e1f17/vbscript-systemphotodatetaken-problem
I have a string called str = "12345-5, 12345-4, 12345-3, 12345-2, 12345-1 I need to reverse the string so it looks like this str = "12345-1, 12345-2, 12345-3, 12345-4, 12345-5"
I have tried the strReverse method, and it almost did what I wanted...
Sub rev()
Dim str As String
str = "12345-5, 12345-4, 12345-3, 12345-2, 12345-1"
str = StrReverse(Trim(str))
'turns out to be str = "1-54321 ,2-54321 ,3-54321 ,4-54321 ,5-54321"
End Sub
but it ended up reversing the whole string, should have guessed that. So I'm wondering should I use a regex expression to parse the string and remove the "12345-" and then reverse it and add it back in? I'm not too sure if that would be the best method for my problem. Does anyone know a solution to my problem or could point me in the right direction? Thanks
Use Split then loop backwards through the array:
Sub rev()
Dim str As String
str = "12345-5, 12345-4, 12345-3, 12345-2, 12345-1"
Dim strArr() As String
strArr = Split(str, ",")
str = ""
Dim i As Long
For i = UBound(strArr) To LBound(strArr) Step -1
str = str & ", " & Trim(strArr(i))
Next i
str = Mid(str, 3)
Debug.Print str
End Sub
I would do it like this:
Sub TestMe()
Dim str As String
str = "12345-5, 12345-4, 12345-3, 12345-2, 12345-1"
str = StrReverse(str)
Dim myArr As Variant
myArr = Split(str, ",")
Dim newString As String
Dim myA As Variant
For Each myA In myArr
newString = newString & StrReverse(myA) & ","
Next myA
newString = Trim(Left(newString, Len(newString) - 1))
Debug.Print newString
End Sub
Getting this:
12345-1, 12345-2, 12345-3, 12345-4,12345-5
In general, this is quite popular Algorithmic problem, which used to be asked by Google for Junior Developers. Sounding like this - Efficiently reverse the order of the words (not characters) in an array of characters
I have 6 text files in one folder.
I want combine selected files in to one text using access.
I have tried this code without success, because the one text file is created but is empty
Can any one help me on this?
Thanks in advance, my code below.
Lines in the text file:
xN;xDate;xNode;xCO;
100;2017-09-26 00:00:00;Valley;D6;
101;2017-09-25 00:00:00;Valley;D3;
...
...
Code:
Dim xPath
Function xExtract()
Dim xArray() As Variant
Dim I As Integer
Dim StrFileName As String
xPath = CurrentProject.Path
PDS:
xArray = Array("D1", "D2", "D3", "D4", "D5", "D6")
new_file = "" & xPath & "\PDS.txt"
fn = FreeFile
Open new_file For Output As fn
Close
For I = 0 To UBound(xArray)
StrFileName = "\\myserver\inetpub\ftproot\PDS_" & xArray(I) & ".txt"
fn = FreeFile
Open StrFileName For Input As fn
Open new_file For Append As fn + 1
Line Input #fn, dato
Do While Not EOF(fn)
Line Input #fn, dato
dati = Split(dato, Chr(9))
For d = 0 To UBound(dati)
If d = 0 Then
dato = Trim(dati(d))
Else
dato = dato & ";" & Trim(dati(d))
End If
Next
Print #fn + 1, dato
Loop
Close
Next I
Application.Quit
End Function
Here's code that works for concatenating comma delimited text files (probably would work for any text files). Pretty crude. Needs error handler and would benefit from common dialog to select output folder and file name. Also I don't like using non-typed variables, but I don't know what type of object some of them are and can't figure it out from Microsoft help. Warning, don't put output in same folder - might result in endless loop - trust me I tried it
Public Function CFiles(Filepath As String) As String
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Folder
Dim Filein As Object
Dim fileout As Object
Dim strText As String
Dim TheInputfile As Object
Dim filename As String
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(Filepath)
Set fileout = FSO.CreateTextFile("c:\InvestmentsPersonal\files\backup\output.txt", ForAppending, False)
For Each Filein In SourceFolder.Files
filename = Filein.Name
Set TheInputfile = FSO.OpenTextFile(Filepath & filename, ForReading)
strText = TheInputfile.ReadAll
TheInputfile.Close
fileout.WriteLine strText
Next
fileout.Close
Set fileout = Nothing
Set Filein = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
CFiles = "c:\InvestmentsPersonal\files\backup\output.txt"
End Function
As your code works for files with windows EOL format (CR (Carriage Return) + LF (Line Feed)), I guess your files are UNIX EOL format (just LF, no CR), check this with a texteditor like e.g. Notepad++ (View->Show Symbol->Show End of Line). This causesLine Inputto read the whole file in one line as it breaks on CR. Then you skip the first line and nothing is inserted, because all text is in this line.
You can useFileSystemObjectto avoid this as it breaks on LF.
Function xExtract()
Const ForReading = 1, ForWriting = 2, ForAppending = 8 'iomode constants
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0 'format constants
Dim xArray As Variant, dati As Variant
Dim i As Long, d As Long
Dim xPath As String, new_file As String, dato As String, StrFileName As String
Dim FSO As Object, TextStreamIn As Object, TextStreamOut As Object
xPath = CurrentProject.Path
new_file = xPath & "\PDS.txt"
xArray = Array("D1", "D2", "D3", "D4", "D5", "D6")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set TextStreamOut = FSO.OpenTextFile(new_file, ForWriting, True, TristateUseDefault) 'open textstream to write
For i = 0 To UBound(xArray) 'loop through files
StrFileName = "\\myserver\inetpub\ftproot\PDS_" & xArray(i) & ".txt"
Set TextStreamIn = FSO.OpenTextFile(StrFileName, ForReading) ' open textstream to read
TextStreamIn.SkipLine 'skip first line with headers
Do Until TextStreamIn.AtEndOfStream 'loop through lines
dati = Split(TextStreamIn.Readline, Chr(9))
For d = 0 To UBound(dati)
If d = 0 Then
dato = Trim(dati(d))
Else
dato = dato & ";" & Trim(dati(d))
End If
Next
TextStreamOut.WriteLine dato 'write line to file
Loop
TextStreamIn.Close 'close textstream
Next i 'next file
TextStreamOut.Close
Set TextStreamOut = Nothing
Set TextStreamIn = Nothing
Set FSO = Nothing
Application.Quit
End Function
If you want to stay withOpen fileyou can split the first (and only) line on LF (Split(dato,vbLf) and ignore the first element, but you have to check the file is UNIX EOL format, FSO covers both.
Im trying to use the replaceline function to update code in Access VBA module. it keeps coming up with a compile error. Ive checked that the VBA Extension are selected and compared it to other examples that I have looked up.
this is the first time that Ive used this type of function, so I haven't fully got my head around them.
code below
Sub ReplaceCodeModuleText(strModule As String, strFindWhat As String, strReplaceWith As String)
'FUNCTION:
' Search the code module for specific text
' Replace with new text
Dim VBProj As VBProject
Dim VBComp As VBComponent
Dim CodeMod As CodeModule
Dim SL As Long ' start line
Dim EL As Long ' end line
Dim SC As Long ' start column
Dim EC As Long ' end column
Dim strCodeLine As String
Dim vDummy As Variant
Dim Found As Boolean
Set VBProj = Application.VBE.ActiveVBProject
Set VBComp = VBProj.VBComponents(strModule)
Set CodeMod = VBComp.CodeModule ' '.CodeModule
With CodeMod
SL = 1: EL = .CountOfLines
SC = 1: EC = 255
Found = .Find(Target:=strFindWhat, StartLine:=SL, StartColumn:=SC, _
EndLine:=EL, EndColumn:=EC, _
wholeword:=True, MatchCase:=False, patternsearch:=False)
If Found Then
strCodeLine = CodeMod.Lines(SL, 1)
strCodeLine = Replace(strCodeLine, strFindWhat, strReplaceWith, Compare:=vbTextCompare) 'not case sensitive = vbTextCompare
.ReplaceLine(SL, strCodeLine)
Debug.Print "Successfully Replaced: " & strFindWhat & " in VBA Module: " & strModule & " with : " & strReplaceWith
Else
Debug.Print "Did not find: " & strFindWhat;
End If
End With
End Sub
.ReplaceLine(SL, strCodeLine)
must be either
Call .ReplaceLine(SL, strCodeLine)
or
.ReplaceLine SL, strCodeLine