I am trying to use the code below, however I don't understand why it is printing out a blank message box? Additionally, there is only one for each day, and it is saying there is 2 files?
How do I print these back effectively, second, how do I then use that to open the sheet?
The files are written as samadmin15112018_??????.csv Where the question marks are a time stamp which I don't know.
Sub runFA()
Const yourfilepath = "R:\samsdrive\sam\test\"
Dim s As String
Dim x As Integer
Dim v() As String
s = Dir(yourfilepath & "samadmin" & format(Sheets("Name").Range("C3"), "yyyymmdd") & "_*.csv")
v = Split(vbNullString)
Do Until s = ""
x = x + 1
ReDim Preserve v(x + 1)
s = Dir()
Loop
If UBound(v) > 0 Then
MsgBox "There are " & UBound(v) & " workbooks", vbOKOnly
MsgBox v(x + 1)
Else
If v(0) <> "" Then Workbooks.Open (yourfilepath & v(0))
MsgBox ("There are 0 ")
End If
End Sub
Fixing the previous answer...
You were getting an empty element because the original code resized the array for the first element, which meant that v(0) was always going to be vbNullString. With string arrays, you can take advantage of the Split function's behavior of returning an array with a UBound of -1 and an LBound of 0 if you're going to add elements to it dynamically:
Sub runFA()
Const targetPath = "R:\samsdrive\sam\test\"
Dim located() As String
located = Split(vbNullString)
Dim result As String
result = Dir$(targetPath & "samadmin" & Format$(Sheets("Name").Range("C3"), "yyyymmdd") & "_*.csv")
Do Until result = vbNullString
ReDim Preserve located(UBound(located) + 1)
located(UBound(located)) = result
result = Dir$()
Loop
If UBound(located) <> 0 Then
MsgBox "There are " & (UBound(located) + 1) & " workbooks", vbOKOnly
Else
Workbooks.Open targetPath & result
End If
End Sub
A couple other things to note
I changed the variable names from single letter identifiers to something a little easier to read and understand.
The indentation is now consistant.
It uses the string typed functions for Dir and Format.
You don't need to track the count of results with x at all.
If you only have one element in the results array, you can simply use result - there isn't any reason to index back into the array.
Related
I have 20 cases. For every row in my sheet, I have a cell that assigns related case numbers to it. A row could have multiple case numbers assigned to it in that cell (Example: 1,2,11,12)
I am writing a code to copy all the rows that have Case number 1 assigned to them, copy them someplace else..
and then go to case number 2 and repeat the same..
This is what I am using:
For CaseNumbers = 1 To 20
For i = Row1 To RowLast
If InStr(1, Range(CaseNoCell & i).Value, CaseNumbers & ",") Then
COPY AND PASTE CODE
End If
Next
Next
The problem I am facing is, the code considers case number 11 as case number 1 too (since it has the digit 1).
This is the first time I am writing a VBA code and I have no background in this.
Can someone please advise on better way of doing this? Should I assign a checklist instead to each row?
All I want to do is find all the rows that have Case number 1 assigned, copy them.. then find all the rows that have Case 2 assigned, copy them.. and so on.
Please help.
You can use a function to do the test
Public Function isCaseNumberIncluded(ByVal caseToCheck As Long, ByVal caseNumbers As String) As Boolean
'add , to make all values distinct
caseNumbers = "," & caseNumbers & ","
Dim strCaseToCheck As String
strCaseToCheck = "," & caseToCheck & ","
If InStr(1, caseNumbers, strCaseToCheck) > 0 Then
isCaseNumberIncluded = True
End If
End Function
You would call this function within your main code like this:
Dim caseNumber As Long 'I removed the s - as this could be misleading in my eyes
For caseNumber = 1 To 20
For i = Row1 To RowLast
If isCaseNumberIncluded(caseNumber, Range(CaseNoCell & i).Value) Then
COPY AND PASTE CODE
End If
Next
Next
Using a separate function to run the test has two advantages:
your code gets more readable, ie you know from reading the functions name what the result should be - without reading the whole code how to do it :-)
you can re-use this code propably at another place
Or you can test the function first:
Public Sub test_isCaseNumberIncluded()
Debug.Print isCaseNumberIncluded(1, "1,2,11,12"), "Should be true"
Debug.Print isCaseNumberIncluded(1, "2,11,12"), "Should be false"
Debug.Print isCaseNumberIncluded(11, "1,2,11,12"), "Should be true"
Debug.Print isCaseNumberIncluded(11, "1,2,12"), "Should be false"
End Sub
Well, you are working with this piece of code:
If InStr(1, Range(CaseNoCell & i).Value, CaseNumbers & ",") Then
This checks against 1,, 12,, ..., but obviously it won't cover the last entry so that's something you'll need to add. And you have the problem that 11, gets treated as 1,.
In a similar way you can use this piece of code:
If InStr(1, Range(CaseNoCell & i).Value, "," & CaseNumbers & ",") Then
This checks against ,1,, ,12,, ... so it will solve your error, but obviously it won't cover the last and the first entry so that's something you'll need to add.
This is something that should be encapsulated in a function rather than being done in line. The method provided in VBA for tokenising a string is 'Split'.
You could wite a function that checks tokens 1 by 1, or which compile a collection of the tokens which then uses a built checking method of the collection to determine if the specified token is present or not.
In this specific case I've chosen to use the collection method. The specific object for the collection is the ArrayList (but a Scripting.Dictionary is also possible). The function contains checks for zero length strings and allows the seperator to be specified if it isn't a comma.
Option Explicit
Function FindToken(ByVal ipToken As String, ByVal ipTokenList As String, Optional ByVal ipSeparator As String = ",") As Boolean
' Guard against ipSeparator being vbnullstring
Dim mySeparator As String
mySeparator = IIf(VBA.Len(ipSeparator) = 0, ",", ipSeparator)
'Raise an error if ipToken or ipTokenList are empty strings
If VBA.Len(ipToken) = 0 Or VBA.Len(ipTokenList) = 0 Then
Err.Raise 17, "Empty string error"
End If
'Convert the token list to tokens
Dim myTokens As Variant
myTokens = VBA.Split(ipTokenList, mySeparator)
' Put the tokens in an ArrayList so we can use the contains method
' no point is doing early binding as arraylist doesn't provide intellisense
Dim myAL As Object
Set myAL = CreateObject("System.Collections.ArrayList")
Dim myItem As Variant
For Each myItem In myTokens
' Trim just in case there are spaces
myAL.Add VBA.Trim(myItem)
Next
'Finally test if the Token exists in the token list
Find = myAL.contains(VBA.Trim(ipToken))
End Function
This means that your code
If InStr(1, Range(CaseNoCell & i).Value, CaseNumbers & ",") Then
can now be rewritten as
If FindToken(CStr(CaseNUmbers), Range(CaseNoCell & cstr(i)).Value) Then
Identify Criteria Rows
Option Explicit
Sub Test()
Const WordSeparator As String = ","
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim CaseNumber As Long
Dim i As Long
Dim cValue As Variant
Dim cString() As String
For CaseNumber = 1 To 20
For i = Row1 To RowLast
cValue = CStr(ws.Range(CaseNoCell & i).Value)
If Len(cValue) > 0 Then
cString = Split(cValue, WordSeparator)
If IsNumeric(Application.Match( _
CStr(CaseNumber), cString, 0)) Then
' CopyAndPasteCode CaseNumber
Debug.Print "Case " & CaseNumber & ": " & "Row " & i
End If
End If
Next i
Next CaseNumber
End Sub
I am required to extract passages of text from the contents of Excel cells in which the originator has essentially done a manual Track Changes using Strikethrough font. The passages are identifiable with certain character patterns, but I have to ignore Strikethrough characters to see them. The Strikethrough characters do not appear in regular locations within each cell, so are essentially randomly dispersed with normal font text.
I have achieved my goal using VBA for Excel, but the solution is extremely (and impracticably) slow. Having searched this site and the wider web for answers, it seems the use of the Characters object is to blame.
So my question is: has anyone found a way of parsing such text that does not involve the Characters object?
The sub I wrote to do the parsing is too long to post here, but following is some test code which uses the Characters object in a similar way. This takes 60 s to parse a cell with 3000 characters in it. At that speed, it would take 50 hours to process the entire spreadsheet I've been given.
Private Sub FindLineBreakChars(TargetCell As Excel.Range)
Dim n As Integer
Dim ch As String
Dim st As Boolean
If TargetCell.Cells.Count <> 1 Then
Call MsgBox("Error: more or less than one cell in range specified.")
Else
If IsEmpty(TargetCell.Value) Then
Call MsgBox("Error: target cell is empty.")
Else
If Len(TargetCell.Value) = 0 Then
Call MsgBox("Error: target cell contains an empty string.")
Else
'Parse the characters in the cell one by one.
For n = 1 To TargetCell.Characters.Count
ch = TargetCell.Characters(n, 1).Text
st = TargetCell.Characters(n, 1).Font.Strikethrough
If ch = vbCr Then
Debug.Print "#" & n & ": Carriage Return (vbCr)" & ", strikethrough = " & st & vbCrLf
ElseIf ch = vbLf Then
Debug.Print "#" & n & ": Line Feed (vbLf)" & ", strikethrough = " & st & vbCrLf
End If
Next n
End If
End If
End If
End Sub
You're right, the access to Characters is very slow, so your goal should be to reduce it's usage as much as possible.
I don't understand your requirement details, but the following code should get you an idea how you could speed up the code. It reads the content of a cell only once, split the text into separate lines, calculates the position of the single linefeed characters and look at that position for the formatting. As far as I know there is no way to access the formatting all at once, but now the access to the characters-object is reduced to one per line:
With TargetCell
Dim lines() As String, lineNo As Integer, textLen As Long
lines = Split(.Value2, vbLf)
textLen = Len(lines(0)) + 1
For lineNo = 1 To UBound(lines)
Dim st
st = .Characters(textLen, 1).Font.Strikethrough
Debug.Print "#" & textLen & ": LineFeed (vbLf) strikethrough = " & st
textLen = textLen + Len(lines(lineNo)) + 1
Next lineNo
End With
To my knowledge, Excel stores Linebreaks in a cell using just the LineFeed character, so the code is checking only that.
This might meet your performance needs: it calls a function which parses the XML representation of the cell content, removes the struck-out sections, and returns the remaining text.
It will be much faster than looping over Characters
Sub Tester()
Debug.Print NoStrikeThrough(Range("A1"))
End Sub
'Needs a reference to Microsoft XML, v6.0
' in your VBA Project references
Function NoStrikeThrough(c As Range) '
Dim doc As New MSXML2.DOMDocument60, rv As String
Dim x As MSXML2.IXMLDOMNode, s As MSXML2.IXMLDOMNode
'need to add some namespaces
doc.SetProperty "SelectionNamespaces", _
"xmlns:ss='urn:schemas-microsoft-com:office:spreadsheet' " & _
"xmlns:ht='http://www.w3.org/TR/REC-html40'"
doc.LoadXML c.Value(11) 'cell data as XML
Set x = doc.SelectSingleNode("//ss:Data")'<< cell content
Set s = x.SelectSingleNode("//ht:S") '<< strikethrough
Do While Not s Is Nothing
Debug.Print "Struck:", s.Text
x.RemoveChild s '<< remove struck section
Set s = x.SelectSingleNode("//ht:S")
Loop
NoStrikeThrough = doc.Text
End Function
EDIT: here's another way to go at it, by breaking up the text into "blocks" and checking each block to see if it has any strikethrough. How much faster this is than going character-by-character may depend on block size and the distribution of struck-out text in each cell.
Function NoStrikeThrough2(c As Range)
Const BLOCK As Long = 50
Dim L As Long, i As Long, n As Long, pos As Long, x As Long
Dim rv As String, s As String, v
L = Len(c.Value)
n = Application.Ceiling(L / BLOCK, 1) 'how many blocks to check
pos = 1 'block start position
For i = 1 To n
v = c.Characters(pos, BLOCK).Font.Strikethrough
If IsNull(v) Then
'if strikethough is "mixed" in this block - parse out
' character-by-character
s = ""
For x = pos To pos + BLOCK
If Not c.Characters(x, 1).Font.Strikethrough Then
s = s & c.Characters(x, 1).Text
End If
Next x
rv = rv & s
ElseIf v = False Then
'no strikethrough - take the whole block
rv = rv & c.Characters(pos, BLOCK).Text
End If
pos = pos + BLOCK 'next block position.
Next i
NoStrikeThrough2 = rv
End Function
EDIT2: if you need to make sure all newline characters are not struck out before processing the cell -
Sub ClearParaStrikes(c As Range)
Dim pos As Long
pos = InStr(pos + 1, c.Value, vbLf)
Do While pos > 0
Debug.Print "vbLf at " & pos
c.Characters(pos, 1).Font.Strikethrough = False
pos = InStr(pos + 1, c.Value, vbLf)
Loop
End Sub
I will try to explain the issue as clear as possible.
I have a column in an Excel file and each cell in this column contains a description of some issue. The description has four levels such as Name, Issue, Solution and Result, all these four in the same cell.
I need VBA code that will find each level in each cell and create line break in the cell.
So instead of this:
Name: 123 Issue: My issue: Solution: Try to resolve Result: Resolved.
After the code runs will be like this:
Name: 123 (line break)
Issue: My issue (line break)
Solution: Try to resolve (line break)
Result: Resolved (line break)
Please let me know if there is any solution?
Select the cell containing the data and run:
Sub FixData()
Dim r As Range
Set r = ActiveCell
t = r.Text
t = Replace(t, "Issue:", Chr(10) & "Issue:")
t = Replace(t, "Solution:", Chr(10) & "Solution:")
t = Replace(t, "Result:", Chr(10) & "Result:")
r.Value = t
r.WrapText = True
End Sub
If necessary, you can put this in a loop.
loop through the cells and add linefeeds.
sub makelfs()
dim i as long, j as long, arr as variant, str as string
arr = array("Issue:","Solution:","Result:")
with worksheets("excel file")
for i=2 to .cells(.rows.count, "a column in excel file").end(xlup).row
str = .cells(i, "a column in excel file").value2
for j = lbound(arr) to ubound(arr)
str = replace(str, arr(j), vblf & arr(j))
next j
.cells(i, "a column in excel file") = str
.cells(i, "a column in excel file").wraptext = true
next i
end with
end sub
s = "Name: 123 Issue: My issue: Solution: Try to resolve Result: Resolved."
arr = Split(s, Chr(32))
For Each Item In arr
If cnt > 0 Then
If Right(Item, 1) = ":" Then Item = vbCrLf & Item
End If
output = output & Item & " "
cnt = cnt + 1
Next Item
Debug.Print output
Using a slightly different approach which doesn't rely on Issue, Solution and Result being present.
As said in my comment - look for the first space before the colon and replace it with a line feed (put vbcr in my comment - should be vblf).
Public Function AddLineBreak(Target As Range) As String
Dim lColon As Long
Dim lSpace As Long
Dim sFinal As String
sFinal = Target.Value
lSpace = Len(sFinal)
Do While lSpace <> 0
sFinal = Left(sFinal, lSpace - 1) & Replace(sFinal, " ", vbLf, lSpace, 1)
lColon = InStrRev(sFinal, ":", lSpace - 1)
lSpace = InStrRev(sFinal, " ", lColon)
Loop
AddLineBreak = Trim(sFinal)
End Function
You can call the function in a procedure:
Sub Test()
Dim rCell As Range
For Each rCell In Sheet1.Range("A1:A13")
rCell = AddLineBreak(rCell)
Next rCell
End Sub
or as a worksheet function:
=AddLineBreak(A1)
This assumes an error in the original string you posted:
Name: 123 Issue: My issue: Solution: Try to resolve Result: Resolved. should be
Name: 123 Issue: My issue Solution: Try to resolve Result: Resolved.
(extra colon before Solution which is not shown in your After code example).
Edit - it also means you cannot have spaces in your headings. So you can have " Issue:" or " My_Issue:" but not " My Issue:"
I searched for an answer to this question, but it seems like the only ways that people have answered it are using Excel functions. I have a file in Excel that I load in to a text file, but new data comes out every week. I need to replace the Market names in this first column with their respective tickers, which are in this separate worksheet, but in the same Excel file.
For example, I want all 'CANADIAN DOLLAR - CHICAGO MERCANTILE EXCHANGE' cells to be replaced with 'CAD', all 'SWISS FRANC - CHICAGO MERCANTILE EXCHANGE' cells to be replaced with 'SWF', etc.
I would prefer if the names remained the same in the Excel file and were only changed when I transferred them to the text file. However, that's not essential if it's harder to do.
For reference, here's the code I'm using to write to the text file:
Sub getData1()
On Error GoTo ErrHandler:
''Finding Row Information
Dim Ticker As String
Dim rCount As Integer, i As Integer, j As Integer, rcCount As Integer, rowStr As String
rCount = Application.CountA([RDRows])
rcCount = Application.CountA([RDCols])
Myfile = "H:\wkoorbusch\Desktop\" & "CFTC_Fin_Data.txt"
Dim fnum As Integer
fnum = FreeFile
Open Myfile For Output As fnum
For i = 1 To rCount
For j = 1 To rcCount
rowStr = [Start].Offset(i, 0).Value & "," & [Start].Offset(0, j).Value _
& "," & Format([Start].Offset(i, 2).Value, _
"mm/dd/yyyy") & "," & [Start].Offset(i, j).Value
Print #fnum, rowStr
Next j
Next i
Close fnum
Exit Sub
ErrHandler:
Close fnum
End Sub
Thanks in advance for any and all help.
Place the Text and its replacement in 2 colums of your spreadsheet, then use
On Error Resume Next
Application.WorksheetFunction.VLookup(MyText,range("Sheet1!A1:B300"),2,False)
If Err.Number=1004 then msgbox "Value " & MyText & " not found"
to return the replacement text.
A trappable err.Number of 1004 is returned when the lookup value is not found.
(functionally equivalent to VLOOKUP as a spreadsheet formula)
I am writing a custom sorting procedure for my Excel spreadsheet that has at least 3 worksheets. On first position I put the worksheet called "Summary", on second goes "Data" and the rest are worksheets whose names are dates ex "17.03.2011", "20.03.2011" etc. Those need to be sorted chronologically.
Here is what I have so far, the script stops with an "Object Required" error on line with the DateDiff() and I have no idea why:
After correcting the code below I am still having trouble in making the thing sort in the right order. Can anyone suggest a way to compare and move around the sheets?
Public Sub ssort()
sSummary.Move before:=Worksheets.Item(1)
sData.Move after:=sSummary
Dim i, n As Integer
Dim diff As Long
Dim current, other As Worksheet
For i = 1 To Worksheets.Count
Set current = Worksheets.Item(i)
If current.Name <> sData.Name And current.Name <> sSummary.Name Then
For n = i + 1 To Worksheets.Count
Set other = Worksheets.Item(n)
diff = DateDiff(DateInterval.day, Format(current.Name, "dd.mm.yyyy"), Format(other.Name, "dd.mm.yyyy"))
If diff > 0 Then
current.Move before:=other
Debug.Print "Moving " & current.Name & " before " & other.Name
ElseIf diff < 0 Then
current.Move after:=other
Debug.Print "Moving " & current.Name & " after " & other.Name
End If
Next n
End If
Next i
End Sub
I think I either don't understand DateDiff() or Format(), could anyone please shed some light on this?
After modifying code from an online example here http://www.vbaexpress.com/kb/getarticle.php?kb_id=72 to use the datediff for comparison, I came up with this solution which works as intended:
Sub sort2()
sSummary.Move before:=Worksheets.Item(1)
sData.Move after:=sSummary
Dim n As Integer
Dim M As Integer
Dim dsEnd, lowest As Integer
Dim dCurrent() As String
Dim dOther() As String
Dim diff As Long
dsStart = 3
dsEnd = Worksheets.Count
For M = dsStart To dsEnd
For n = M To dsEnd
If Worksheets(n).Name <> "Summary" And Worksheets(n).Name <> "Data" And Worksheets(M).Name <> "Summary" And Worksheets(M).Name <> "Data" Then
dCurrent = Split(CStr(Worksheets(n).Name), ".")
dOther = Split(CStr(Worksheets(M).Name), ".")
diff = DateDiff("d", DateSerial(dCurrent(2), dCurrent(1), dCurrent(0)), DateSerial(dOther(2), dOther(1), dOther(0)))
If diff > 0 Then
Worksheets(n).Move before:=Worksheets(M)
End If
End If
Next n
Next M
End Sub
The DateDiff function requires the two date arguments to be of Variant (Date) type. Instead you're giving it two String arguments, which is what the Format function returns.
You need to convert each of the Strings to Variant (Date). This can be done like this:
strDate = current.Name ' String: "20.03.2011"
aintDateElements = Split(strDate, ".") ' Array: {2001, 03, 20}
varDate = DateSerial(aintDateElements(2), aintDateElements(1),
aintDateElements(0)) ' Variant (Date)
There are other ways of doing this conversion, but I find that this is the way that least often gives unexpected results!
If you took this code off of the web, be aware that DateInterval isn't a native Excel object or a VBA object, it's a .Net object. You could just substitute "d" for "DateInterval.day".
diff = DateDiff("d", Format(current.Name, "dd.mm.yyyy"), _
Format(other.Name, "dd.mm.yyyy"))
If you're getting error messages in Format/Datediff calls, try split them into separated statements. You'll see where the problem lies.
Example:
dtStart = CDate(Format(current.Name, "dd.mm.yyyy"))
dtEnd = CDate(Format(other.Name, "dd.mm.yyyy"))
diff = DateDiff("d", dtStart, dtEnd)