I am facin strange problem looks like = is not working as it should be. I got code below:
Dim lineText As String
For Each p In WordDoc.Paragraphs
lineText = p.Range.Text
If lineText = "" Then GoTo Dalej
.....
even if i do:
lineText = ""
If lineText = "" Then GoTo Dalej
its not going to Dalej but going next. Looks like its not problem with code but with operators i got similar problem with <>. I tried to workaround tht with InStr or StrComp but its doing completly not as it should be like something inside excel has been changed with application itself. Do you have any idea what this could be?
This is full code:
Sub Sprawdz_Pola_Korespondencji_Click()
Application.ScreenUpdating = True
Dim RowNr As Integer
Dim EWS As Worksheet
RowNr = 30
Set EWS = Sheets("Arkusz do wypełnienia")
Dim FileName As Variant, wb As Workbook
FileName = Application.GetOpenFilename(FileFilter:="Word File (*.docx),*.docx", Title:="Select File To Be Opened")
If FileName = False Then Exit Sub
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = False
Set WordDoc = WordApp.Documents.Open(FileName)
Dim p As Paragraph
If lineText = "" Then GoTo Dalej
If InStr(lineText, PoleExcel) Then
EWS.Cells(5, X).Interior.ColorIndex = 18
Else
EWS.Cells(5, X).Interior.ColorIndex = 3
End If
Dalej:
Next p
Nastepna:
Loop Until EWS.Cells(RowNr, X) = "KONIEC"
'EWS.Activate 'WordDoc.Activate '<============================================================
WordDoc.Close savechanges:=False 'or false
WordApp.Quit
Set WordDoc = Nothing
Set WordApp = Nothing
End Sub
Public Function ReplaceSpaces(strInput As String) As String
' Replaces spaces in a string of text with underscores
Dim Result As String
Result = strInput
If InStr(strInput, " ") > 0 Then
Result = Replace(strInput, " ", "_")
End If
ReplaceSpaces = Result
End Function
You need to write:
Next p
Dalej:
instead. (i.e. switch round the Next p and Dalej:). Currently the label is inside the for loop.
But, it would be far better to use Exit For instead of the GoTo. Doing this means you don't need to maintain a label.
GoTo statements are notoriously brittle.
To strip out the CR do this:
lineText = replace(lineText, chr(13), "")
Related
I have a Word doc with some numbers referred in the foot notes. and I am exporting these references as a csv file.
Sub FindNumber()
Dim exp, exp1 As RegExp
Set exp = New RegExp
exp.Pattern = "\b[A-Za-z]{3}[0-9]{7}\b"
exp.Global = True
Dim splits(1000) As String
Dim x As Long
Dim results As MatchCollection
Set results = exp.Execute(ActiveDocument.StoryRanges(wdFootnotesStory))
x = 1
For Each res In results
splits(x) = res
x = x + 1
Next res
Dim Filename As String, line As String
Dim i As Integer
Filename = "C:\VBA Export" & "\Numbers.csv"
Open Filename For Output As #2
Print #2, "Control Numbers"
For i = LBound(splits) To UBound(splits)
Print #2, splits(i)
Next i
Close #2
MsgBox "Numbers were exported to " & Filename, vbInformation
End Sub
The code above was working fine and just suddenly starting throwing error at 'splits(x) = res'
I have tried checking my regex and I can see that it works fine. If I change splits(x) to splits(6) or something similar it works like a charm .
Can someone please help ?
EDIT - changed code to write matches directly to Excel.
Sub Tester()
Dim oXl As Excel.Application 'add reference to MS Excel object library...
Dim oWb As Excel.Workbook, c As Excel.Range, i As Long, col As Collection
Set oXl = New Excel.Application
oXl.Visible = True
Set oWb = oXl.Workbooks.Add()
Set c = oWb.Worksheets(1).Range("A1")
ListMatchesInExcel ActiveDocument.StoryRanges(wdFootnotesStory), _
"\b[A-Za-z]{3}[0-9]{7}\b", _
"Id Numbers", c
Set c = c.Offset(0, 1)
ListMatchesInExcel ActiveDocument.StoryRanges(wdFootnotesStory), _
"\b[A-Za-z]{2}[0-9]{9}\b", _
"Other Numbers", c
Set c = c.Offset(0, 1)
'etc etc
End Sub
'Search through `SearchText` for text matching `patt` and export all
' matches to Excel with a header `HeaderText`, starting at range `c`
Sub ListMatchesInExcel(SearchText As String, patt As String, _
headerText As String, c As Excel.Range)
'add reference to MicroSoft VBscript regular expressions
Dim exp, exp1 As RegExp, col As New Collection
Dim results As MatchCollection, res As Match, i As Long
Set exp = New RegExp
exp.Pattern = patt
exp.Global = True
Set results = exp.Execute(SearchText)
'log to Immediate pane
Debug.Print (col.Count - 1) & " matche(s) for '" & patt & "'"
c.Value = headerText
i = 1
For Each res In results
c.Offset(i).Value = res
i = i + 1
Next res
c.EntireColumn.AutoFit
End Sub
I have a old legacy code which is programmed for mail merge. I have a add-in code to populate xls file which in turn should merge the data to word template defined. Code snippet :
Public Sub ProcessForSharePoint(DataSource As Object, MainDoc As Document)
Dim tempPath As String
Dim i As Integer
Dim recordCount As Integer
Dim ActualCount As Integer
Dim ws As Variant
Dim tempName As String
Dim rowEmpty As Boolean
On Error GoTo tempFileError
tempName = Left(MainDoc.name, InStrRev(MainDoc.name, ".") - 1)
tempPath = Environ("TEMP") + "\" + tempName + ".xls"
If (Dir(tempPath) <> "") Then
SetAttr tempPath, vbNormal
Kill tempPath
End If
DataSource.SaveAs (tempPath)
On Error GoTo openDataSourceError
MainDoc.MailMerge.OpenDataSource tempPath, ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True,
AddToRecentFiles:=False, Revert:=False, Connection:="Entire Spreadsheet", SubType:=wdMergeSubTypeWord2000
recordCount = 0
On Error GoTo wsError
Set ws = DataSource.WorkSheets(1)
Dim r As Integer
Dim c As Integer
' Work out how many rows we have to process
For r = 2 To ws.UsedRange.Rows.Count
rowEmpty = True
For c = 1 To ws.UsedRange.Columns.Count
If Not IsEmpty(ws.Cells(r, c)) Then
rowEmpty = False
Exit For
End If
Next c
If rowEmpty Then
Exit For
End If
recordCount = recordCount + 1
Next r
GoTo DoMerge
wsError:
GoTo CloseMerge
DoMerge:
ActualCount = 0
If (recordCount = 0) Then
OutputDebugString "PSLWordDV: ProcessForSharePoint: No records to process"
GoTo CloseMerge
End If
On Error GoTo mergeError
For i = 1 To recordCount
' .Destination 0 = DOCUMENT, 1 = PRINTER
MainDoc.MailMerge.Destination = 0 'wdSendToNewDocument
MainDoc.MailMerge.SuppressBlankLines = True
With MainDoc.MailMerge.DataSource
.FirstRecord = i 'wdDefaultFirstRecord
.LastRecord = i 'wdDefaultLastRecord
.ActiveRecord = i
End With
MainDoc.MailMerge.Execute Pause:=False
Populate MainDoc, ActiveDocument
ActualCount = ActualCount + 1
Next i
GoTo CloseMerge
When I call this function, my xls files gets open and populate data (I want data from Sheet 1 only). Then my WORD opens (OpenDataSource) and on selection of "Yes" for population on Word --> My code fails and catches the error "462".
On further analysis (not sure correct or not), it seems, there is a problem in :
Set ws = DataSource.WorkSheets(1)
NOTE: If I hard code my recordCount variable to 1 (say) -> merging process works absolutely fine.
Can anyone please help on priority to sort my client issue please.
My code gives me error from
If Dir(Pth, vbArchive) <> vbNullString Then
I havent been able to find the error - Can someone help me what is wrong with the code? Is it supposed to say USERPROFILE, or am i supposed to write something else?
Sub Opgave8()
Dim sh As Worksheet
Dim Pth As String
Application.ScreenUpdating = False
' Create default desktop path using windows user id
user_id = Environ$("USERPROFILE")
' Create full path
file_name$ = "\AdminExport.csv"
Pth = Environ$("USERPROFILE") & "\Desktop\" & FileName
Set sh = Sheets.Add
For i = 2 To 18288
If Left(Worksheets("Base").Cells(i, 12), 6) = "262015" Then
sh.Cells(i, 2) = Worksheets("Base").Cells(i, 4)
End If
Next i
sh.Move
If Dir(Pth, vbArchive) <> vbNullString Then
overwrite_question = MsgBox("File already exist, do you want to overwrite it?", vbYesNo)
End If
If overwrite_question = vbYes Then
With ActiveWorkbook
.SaveAs FileName:=Pth, FileFormat:=xlCSV
.Close False
End With
End If
Application.ScreenUpdating = True
End Sub
Function UniqueRandDigits(x As Long) As String
Dim i As Long
Dim n As Integer
Dim s As String
Do
n = Int(Rnd() * 10)
If InStr(s, n) = 0 Then
s = s & n
i = i + 1
End If
Loop Until i = x + 1
UniqueRandDigits = s
End Function
There are a few issues in your code. I don't understand why you are getting an error message, but if you fix your issues, you are in a better position of finding the main problem.
Put Option Explicit at the top. If you do that, you will not do mistakes like setting the variable file_name$ but reading from the variable FileName.
You are building a path with double backslashes. Perhaps not a big thing and it'll probably work. Add a Debug.Print Pth just before your troublesome If. Press Ctrl-G to show the debug pane and study the output. Does the printed file path exist?
Don't use vbNullString. Test with abc <> "" instead.
I need to change Colors of certain Shapes in a slide, based on the criteria if the shape is an EndConnectedShape of certain Connectors (the connectors are selected based on some data in a .txt file, but the data input part works fine).
Although it must be straightforward, the part where I try to get the Shape by its Name is still not working:
Sub test()
Dim oFSO As FileSystemObject
Set oFSO = New FileSystemObject
Dim oFS As TextStream
Dim i, j As Long
Dim filePath, smth As String
filePath = "C:\MyPath\MyFile.txt"
If oFSO.FileExists(filePath) Then
On Error GoTo Err
Set oFS = oFSO.OpenTextFile(filePath)
For i = 1 To 1
smth = VecNames(j) ' ADDED
wholeLine1 = oFS.ReadLine
VecNames = Split(wholeLine1, ",")
wholeLine2 = oFS.ReadLine
VecSIs = Split(wholeLine2, ",")
For j = 1 To UBound(VecNames)
With ActivePresentation.Slides(i)
For Each oSh In ActivePresentation.Slides(i).Shapes
If oSh.Connector And oSh.Name = smth Then
'Degub.Print oSh.Name
oSh.Line.ForeColor.RGB = RGB(255, 0, 0)
oSh.Line.Weight = VecSIs(j) * 5
strShNm = oSh.ConnectorFormat.EndConnectedShape.Name
' NEXT LINE IS NOT WORKING :
mySh = ActivePresentation.Slides(i).Shapes(strShNm)
' When tried to change the line above to the one below which is commented out, it DOESN'T work either:
' mySh = Selection.ShapeRange(strShNm)
With mySh
mySh.Line.ForeColor.RGB = RGB(255, 0, 0)
End With
ElseIf oSh.Type = msoTextBox Then
If mySh.TextFrame.TextRange.Text = VecNames(j) Then
oSh.TextFrame.TextRange.Font.Color = RGB(255, 0, 0)
End If
End If
Next oSh
End With
Next j
Next i
oFS.Close
Else
MsgBox "The file path is invalid.", vbCritical, vbNullString
Exit Sub
End If
Exit Sub
Err:
MsgBox "Error while reading the file.", vbCritical, vbNullString
oFS.Close
Exit Sub
End Sub
Any idea what am I doing wrong? Thanks!
In this code:
strShNm = oSh.ConnectorFormat.EndConnectedShape.Name
mySh = ActivePresentation.Slides(i).Shapes(strShNm)
You're getting the name from the shape, then trying to get the shape from the name...
Much easier to do this (and don't forget to use Set):
Set mySh = oSh.ConnectorFormat.EndConnectedShape
I need help in finding an exact match by using VBA in Excel. Here is my object 7 problem.
Objective - to batch process finding and replacing words.
This is a routine task which I'm trying to automate. The task involves finding terms and then replacing them with an alternate word. E.g if the term to be found is "microsoft", I want it to be replaced with say "Company".
While majority of the code is working the limitation is --> if there are two words to be found e.g. 1. Gold 2. Golden and then replace "gold" with "metal" and golden with " mineral here's what happens. If the code find Golden anywhere then the word gold is replaced first and the end product looks like this. Metalen. can someone please help?
Dim wksheet As Worksheet
Dim wkbook As Workbook
Dim fo_filesys As New Scripting.FileSystemObject
Dim RegExpObject As Object
Private Sub cmd_Start_Click()
Dim lsz_dest_path As String
Dim lsz_extn_to_use As String
Dim lsz_filename As String
Dim li_rowtoread As Integer
Application.DisplayAlerts = False
Application.ScreenUpdating = False
lsz_dest_path = VBA.Strings.Trim(Cells(1, 6))
lsz_extn_to_use = VBA.Strings.Trim(Cells(2, 6))
Set RegExpObject = CreateObject("VBScript.RegExp")
RegExpObject.IgnoreCase = True
RegExpObject.Global = True
lsz_filename = Dir(lsz_dest_path & "\" & lsz_extn_to_use)
Do While lsz_filename <> ""
Application.StatusBar = "Scrubbing " & lsz_filename
Set wkbook = Workbooks.Open(lsz_dest_path & "\" & lsz_filename)
For Each wksheet In wkbook.Worksheets
wksheet.Activate
li_rowtoread = 2
Do While Cells(li_rowtoread, 1) <> ""
user_process_file Cells(li_rowtoread, 1), Cells(li_rowtoread, 2), lsz_filename
li_rowtoread = li_rowtoread + 1
DoEvents
Loop
Next wksheet
wkbook.Close True
lsz_filename = Dir
Loop
Application.StatusBar = ""
End Sub
Sub user_process_file(lsz_searh_str As String, lsz_replace_str As String, filename As String)
Dim myRange As Range
Dim lo_tstream As TextStream
Dim lo_reader_tstream As TextStream
Dim lsz_file As String
Dim lb_replaced As Boolean
If fo_filesys.FileExists(filename & ".log") Then
Set lo_reader_tstream = fo_filesys.OpenTextFile(filename & ".log", ForReading)
lsz_file = lo_reader_tstream.ReadAll
lo_reader_tstream.Close
End If
If lsz_searh_str = "RRD" Then
' MsgBox "Here"
End If
Set myRange = wksheet.Cells
myRange.Cells.Find(What:="", After:=ActiveCell, lookat:=xlPart).Activate
'myRange.Replace What:=lsz_searh_str, Replacement:=lsz_replace_str, LookAt:=xlWorkbook, MatchCase:=False, searchorder:=xlByRows ', LookIn:=xlFormulas
With myRange
Set c = .Find(lsz_searh_str, LookIn:=xlValues, lookat:=xlPart)
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.Value = CustomReplace(c.Value, lsz_searh_str, lsz_replace_str)
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
Set lo_tstream = fo_filesys.OpenTextFile(filename & ".log", ForAppending, True)
lb_replaced = myRange.Replace(What:=lsz_searh_str, Replacement:=lsz_replace_str, lookat:=xlWhole, MatchCase:=True, searchorder:=xlByRows)
If lb_replaced = True Then
lo_tstream.WriteLine lsz_replace_str
lo_tstream.Close
End If
End Sub
Function user_eval(lookfor As String, loc_data As String) As Boolean
Dim lsz_val_at_loc As String
If InStr(1, loc_data, lookfor) = 1 Then
user_eval = True
Else
user_eval = False
End If
End Function
Function CustomReplace(OriginalString As String, FindString As String, ReplaceString As String)
RegExpObject.Pattern = "[^a-zA-Z0-9]*" & FindString & "[^a-zA-Z0-9]*"
CustomReplace = RegExpObject.Replace(OriginalString, ReplaceString)
End Function
I do not have permissions to add a comment, so answering the only way I can:
There is a problem with your regex find string [^a-zA-Z0-9]* and [^a-zA-Z0-9]*.
Try using \bgold\w+\b to match words starting with gold and \bgold\b to match gold exactly.
Although I'm answering late, it might help somebody who has a similar problem...