Related
I have some date data that I want to clean up and remove any text that is in the date.
I have the following code that outputs data to a worksheet, and it has a separate datecleanup function that does some of the date cleanup if there is a missing date, or it is only 4 digits, however I am still getting data outputted that contains a mixture of dates and text (examples below).
Main function:
Function TetanusLoad(col As String, col2 As String)
Dim i As Long, j As Long, k As Long
j = Worksheets("CI").Range("A" & Rows.Count).End(xlUp).Row + 1
k = Worksheets("Error").Range("A" & Rows.Count).End(xlUp).Row + 1
For i = 2 To lstrow
If Len(Worksheets("Data").Range(col & i).Value) = 0 And
Len(Worksheets("Data").Range(col2 & i).Value) = 0 Then
GoTo EmptyRange
Else
strDate = spacedate(Worksheets("Data").Range(col & i).Value)
Worksheets("CI").Range("A" & j & ":C" & j).Value =
Worksheets("Data").Range("F" & i & ":H" & i).Value
Select Case Worksheets("Data").Range(col2 & i).Value
Case "Tdap"
Worksheets("CI").Range("D" & j).Value = "TDA"
Case "Td"
Worksheets("CI").Range("D" & j).Value = "TD"
Case Else
Worksheets("CI").Range("D" & j).Value = "REVIEW"
End Select
Worksheets("CI").Range("E" & j).Value = datecleanup(strDate)
j = j + 1
End If
EmptyRange:
Next i
End Function
datecleanup function:
Function datecleanup(inputdate As Variant) As Variant
If Len(inputdate) = 0 Then
inputdate = "01/01/1901"
Else
If Len(inputdate) = 4 Then
inputdate = "01/01/" & inputdate
Else
If InStr(1, inputdate, ".") Then
inputdate = Replace(inputdate, ".", "/")
End If
End If
End If
datecleanup = inputdate
End Function
Sample data output examples for column E that I am trying to correct:
07/06/1993 - HAD ALLERGIC REACTION ; ARM SWELLED AND GOT RED AND HOT
09/23/2004 - REPORTS REACTION TO TETANUS SHOT
12/03/2015 Rubelo reported
I don't want the additional text included, as this should be a date only field. How can I accomplish this? Ideally I would like it to be referenced in the datecleanup function as other functions use this as well.
Taking Nathan's and expanding on it in case of text before date:
Function dateclean(strInput As String) As String
Dim strSplits As Variant, i As Integer, dateFound As String
strSplits = Split(strInput, Chr(32))
For i = 0 To UBound(strSplits)
If strSplits(i) Like "*/*/*" Then
dateFound = strSplits(i)
Exit For
End If
Next i
dateclean = dateFound
End Function
Something like this
function dateclean(strInput as string) as string
dateclean=split(strInput,chr(32))(0)
end function
Not sure what all your code is meant to be doing - it doesn't say where lstRow is defined.
This sample has your examples in the range Data!D2:D4.
The output will appear in the range CI!D2:D4.
Note - I've updated some variable names (although they're not used).
E.g. It's a bit more obvious what CI_LastRow contains, rather than figuring out what j stands for.
Sub Test()
TetanusLoad 4, 5
End Sub
Public Sub TetanusLoad(col As Long, col2 As Long)
Dim CI_LastRow As Long, Error_LastRow As Long
Dim Data_Range As Range, rCell As Range
CI_LastRow = Worksheets("CI").Cells(Rows.Count, 1).End(xlUp).Row + 1
Error_LastRow = Worksheets("Error").Cells(Rows.Count, 1).End(xlUp).Row + 1
'This is the range containing your date/text strings.
With Worksheets("Data")
Set Data_Range = .Range(.Cells(1, col), .Cells(.Rows.Count, col).End(xlUp))
End With
For Each rCell In Data_Range
Worksheets("CI").Cells(rCell.Row, 5) = datecleanup(rCell)
Next rCell
End Sub
Function datecleanup(inputdate As Variant) As Variant
Dim re, match
Set re = CreateObject("vbscript.regexp")
re.Pattern = "[\d]+[\/-][\d]+[\/-][\d]+"
re.Global = True
For Each match In re.Execute(inputdate)
If IsDate(match.Value) Then
datecleanup = CDate(match.Value)
Exit For
End If
Next
Set re = Nothing
End Function
The datecleanup function is a copy of the FormatOutput function found on this link:
VBA Regular Expression to Match Date
In VBA if I have a string of numbers lets say ("1,2,3,4,5,2,2"), how can I remove the duplicate values and only leave the first instance so the string says ("1,2,3,4,5").
Here is a function you can use to dedupe a string as you've described. Note that this won't sort the deduped string, so if yours was something like "4,2,5,1,3,2,2" the result would be "4,2,5,1,3". You didn't specify you needed it sorted, so I didn't include that functionality. Note that the function uses , as the default delimiter if not specified, but you can specify a delimiter if you choose.
Function DeDupeString(ByVal sInput As String, Optional ByVal sDelimiter As String = ",") As String
Dim varSection As Variant
Dim sTemp As String
For Each varSection In Split(sInput, sDelimiter)
If InStr(1, sDelimiter & sTemp & sDelimiter, sDelimiter & varSection & sDelimiter, vbTextCompare) = 0 Then
sTemp = sTemp & sDelimiter & varSection
End If
Next varSection
DeDupeString = Mid(sTemp, Len(sDelimiter) + 1)
End Function
Here's some examples of how you would call it:
Sub tgr()
MsgBox DeDupeString("1,2,3,4,5,2,2") '--> "1,2,3,4,5"
Dim myString As String
myString = DeDupeString("4-2-5-1-3-2-2", "-")
MsgBox myString '--> "4-2-5-1-3"
End Sub
I suggest writing a Join function to combine the unique parts back into a single string (there is one available for arrays, but not for any other collection):
Function Join(Iterable As Variant, Optional Delimiter As String = ",") As String
Dim notFirst As Boolean
Dim item As Variant
For Each item In Iterable
If notFirst Then
Join = Join & Delimiter
Else
notFirst = True
End If
Join = Join & item
Next
End Function
Then, use Split to split a string into an array, and Scripting.Dictionary to enforce uniqueness:
Function RemoveDuplicates(s As String, Optional delimiter As String = ",") As String
Dim parts As String()
parts = Split(s,delimiter)
Dim dict As New Scripting.Dictionary
Dim part As Variant
For Each part In parts
dict(part) = 1 'doesn't matter which value we're putting in here
Next
RemoveDuplicates = Join(dict.Keys, delimiter)
End Function
try this:
Sub test()
Dim S$: S = "1,2,3,4,5,2,2,5,6,6,6"
Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
Dim Key As Variant
For Each Key In Split(S, ",")
If Not Dic.exists(Trim(Key)) Then Dic.Add Trim(Key), Nothing
Next Key
S = Join(Dic.Keys, ","): MsgBox S
End Sub
Heres my crack at it:
Function Dedupe(MyString As String, MyDelimiter As String)
Dim MyArr As Variant, MyNewArr() As String, X As Long, Y As Long
MyArr = Split(MyString, MyDelimiter)
ReDim MyNewArr(0)
MyNewArr(0) = MyArr(0)
Y = 0
For X = 1 To UBound(MyArr)
If InStr(1, Join(MyNewArr, MyDelimiter), MyDelimiter & MyArr(X)) = 0 Then
Y = Y + 1
ReDim Preserve MyNewArr(Y)
MyNewArr(Y) = MyArr(X)
End If
Next
Dedupe = Join(MyNewArr, MyDelimiter)
End Function
Call it like this in code:
Dedupe(Range("A1").Text,",")
Or like this in the sheet:
=Dedupe(A1,",")
The first parameter is the cell to test and the second is the delimiter you want to use (in your example it is the comma)
vb6,Find Duplicate letter in word when there is no delimiter.
Function RemoveDuplicateLetter(ByVal MyString As String) As String
Dim MyArr As Variant, MyNewArr() As String, X As String,str as String
Dim bValue As Boolean
Dim i As Long, j As Long
For i = 0 To Len(MyString)
str = str & Mid$(MyString, i + 1, 1) & vbNullChar
Next
i = 0
MyArr = Split(str, vbNullChar)
ReDim MyNewArr(0)
MyNewArr(0) = MyArr(0)
For i = LBound(MyArr) To UBound(MyArr)
bValue = True
For j = i + 1 To UBound(MyArr)
If MyArr(i) = MyArr(j) Then
bValue = False
Exit For
End If
Next
If bValue Then X = X & " " & MyArr(i)
Next
RemoveDuplicateLetter = X
End Function
I need to do it for more than 1000 cells, to read the particular data and to put under respective cells using Excel VBA.
Example:
Name Age No. .. .
abc 14 123454 ------>this from single cell
Which contains like Name: abc,Age: 14, No: 123454
This should be a good start :
Sub Split_N_Copy()
Dim InFo()
Dim InfSplit() As String
InFo = ActiveSheet.Cells.UsedRange.Value2
Sheets.Add after:=Sheets(Sheets.Count)
For i = LBound(InFo, 1) To UBound(InFo, 1)
'Here I put InFo(i,1), "1" if we take the first column
InfSplit = Split(InFo(i,1), ",")
For k = LBound(InfSplit) To UBound(InfSplit)
Sheets(Sheets.Count).Cells(i + 1, k + 1) = InfSplit(k)
Next k
Next i
End Sub
I write a function based on , for separator sign and : for equal sign, that search a range of data that first row contains headers:
Function UpdateSheet(allData As String, inRange As Range)
Dim strData() As String
Dim i As Long, lastRow As Long
Dim columnName As String, value As String
Dim cell As Range
'You need to change this to finding last row like this answer:
'http://stackoverflow.com/a/15375099/4519059
lastRow = 2
strData = Split(allData, ",")
For i = LBound(strData) To UBound(strData)
columnName = Trim(Left(strData(i), InStr(1, strData(i), ":") - 1))
value = Trim(Mid(strData(i), InStr(1, strData(i), ":") + 1))
For Each cell In inRange
If cell.Cells(1, 1).Rows(1).Row = 1 Then
If cell.Cells(1, 1).value Like "*" & columnName & "*" Then
inRange.Worksheet.Cells(lastRow, cell.Columns(1).Column).value = value
End If
End If
Next
Next
End Function
Now you can use that function like this:
Sub update()
Call UpdateSheet("Name: abc,Age: 14, No: 123454", Sheets(1).UsedRange)
End Sub
Private Sub CommandButton1_Click()
lastRow = Sheet1.Cells(Sheet1.Rows.Count, "G").End(xlUp).Row
Dim i As Integer
i = 2
For i = 2 To lastRow
Dim GetData As String
GetData = Sheet1.Cells(i, 7)
Call UpdateSheet(GetData, Sheets(1).UsedRange, i)
Next
End Sub
Function UpdateSheet(allData As String, inRange As Range, rowno As Integer)
Dim strData() As String
Dim i As Long, lastRow As Long
Dim columnName As String, value As String
Dim cell As Range
strData = Split(allData, ",")
For i = LBound(strData) To UBound(strData)
Value1 = Trim(Mid(strData(i), InStr(1, strData(i), ":") + 1))
If Value1 <> "" Then
columnName = Trim(Left(strData(i), InStr(1, strData(i), ":") - 1))
value = Trim(Mid(strData(i), InStr(1, strData(i), ":") + 1))
For Each cell In inRange
If cell.Cells(1, 1).Rows(1).Row = 1 Then
If cell.Cells(1, 1).value Like "*" & columnName & "*" Then
inRange.Worksheet.Cells(rowno, cell.Columns(1).Column).value = value
End If
End If
Next
End If
Next
End Function
I have multiple values in cell A1 which are separated by a ';'. Some of the same values may be in cell B1. I need to search the values in cell A1 using those in cell B1. All the values that are not found then need to presented in cell C1.
Eg - Cell A1 ( Apple;Orange;Cherry) cell B1 (Apple;Orange;) cell c1 need to reflect "Cherry" as not found
I tried this code:
Sub Splitvalue()
Dim str, mystr As Variant
Dim tp As Integer
str = Split(Range("A1").Value, ";")
For tp = LBound(str) To UBound(str)
mystr = str(tp)
Next
End Sub
Set up your sheet1 like this
the use this code
Option Explicit
Sub Splitvalue()
Dim lastRow As Long
lastRow = Range("A" & Rows.Count).End(xlUp).Row
Dim c As Range
Dim A As Variant, B As Variant
Dim i As Long, j As Long
Dim x As Boolean
Columns(3).ClearContents
For Each c In Range("A1:A" & lastRow)
A = Split(c, ";")
B = Split(c.Offset(0, 1), ";")
For i = LBound(A) To UBound(A)
For j = LBound(B) To UBound(B)
If A(i) = B(j) Then
x = True
Exit For
Else
x = False
End If
Next j
If Not x Then
If IsEmpty(c.Offset(0, 2)) Then
c.Offset(0, 2) = A(i)
Else
c.Offset(0, 2).Value = c.Offset(0, 2).Value & ";" & A(i)
End If
End If
Next i
Next
End Sub
and your results should look like this
Why not just split the second cell like you split the first cell? Then see if you find each element of A1 in B1, otherwise output to C1?
This is not elegant, but will work:
Sub Splitvalue()
Dim str, mystr As Variant
Dim stri As Variant
Dim tp As Integer
str = Split(Range("A1").Value, ";")
str2 = Split(Range("B1").Value, ";")
For tp = LBound(str) To UBound(str)
mystr = str(tp)
'Debug.Print mystr
Dim found As Boolean
found = False
For Each stri In str2
'Debug.Print stri
If stri = mystr Then
found = True
End If
Next stri
If found = False Then
Debug.Print mystr
End If
Next
End Sub
One way:
dim needle() as string: needle = split(Range("B1").Value, ";")
dim haystack as string: haystack = ";" & Range("A1").Value & ";"
dim i as long
for i = 0 To ubound(needle)
haystack = replace$(haystack, ";" & needle(i) & ";", ";")
next
If len(haystack) = 1 then haystack = ";;"
Range("C1").Value = Mid$(haystack, 2, Len(haystack) - 2)
I would really appreciate it if someone could give me some help with this.
I am quite familiar with vba and I can write simple code and also customise code from others. I have written /customised/copied several pieces of vba code to do the following (where copied source is acknowledged):
Select 2 different csv files which represent 2 matrixes of same columns and same rows.
Multiply each respective cells from the matrices.
Return results.
Unfortunately I cannot seem to be able to get this to run.
Any idea what I have not done correctly?
Please see the code below. Thanks so much.
Code changed from previous version
Public Sub doIt()
Dim sourceFile As String
Dim destinationFile As String
Dim data As Variant
Dim result As Variant
Dim sourceFile2 As String
Dim datarain As Variant
sourceFile = "C:\file1.csv"
sourceFile2 = "C:\file2.csv"
destinationFile = "C:\file3.txt"
data = getDataFromFile(sourceFile, ",")
datarain = getDataFromFile(sourceFile2, ",")
If Not isArrayEmpty(data) Then
result = MMULT2_FUNC(data, datarain)
writeToCsv result, destinationFile, ","
Else
MsgBox ("Empty file")
End If
End Sub
Function MMULT2_FUNC(ByRef ADATA_RNG As Variant, _
ByRef BDATA_RNG As Variant)
Dim i As Long
Dim j As Long
Dim k As Long
Dim ANROWS As Long
Dim BNROWS As Long
Dim ANCOLUMNS As Long
Dim BNCOLUMNS As Long
Dim ADATA_MATRIX As Variant
Dim BDATA_MATRIX As Variant
Dim TEMP_MATRIX As Variant
On Error GoTo ERROR_LABEL
ADATA_MATRIX = ADATA_RNG
BDATA_MATRIX = BDATA_RNG
ANROWS = UBound(ADATA_MATRIX, 1)
BNROWS = UBound(BDATA_MATRIX, 1)
ANCOLUMNS = UBound(ADATA_MATRIX, 2)
BNCOLUMNS = UBound(BDATA_MATRIX, 2)
If ANCOLUMNS <> BNROWS Then: GoTo ERROR_LABEL
ReDim TEMP_MATRIX(1 To ANROWS, 1 To BNCOLUMNS)
For i = 1 To ANROWS
For j = 1 To BNCOLUMNS
TEMP_MATRIX(i, j) = 0
For k = 1 To ANCOLUMNS
TEMP_MATRIX(i, j) = TEMP_MATRIX(i, j) + ADATA_MATRIX(i, k) * _
BDATA_MATRIX(k, j)
Next k
Next j
Next i
MMULT2_FUNC = TEMP_MATRIX
Exit Function
ERROR_LABEL:
MMULT2_FUNC = Err.Number
End Function
Public Sub writeToCsv(parData As Variant, parFileName As String, parDelimiter As String)
If getArrayNumberOfDimensions(parData) <> 2 Then Exit Sub
Dim i As Long
Dim j As Long
Dim FileNum As Long
Dim locLine As String
Dim locCsvString As String
FileNum = FreeFile
If Dir(parFileName) <> "" Then Kill (parFileName)
Open parFileName For Binary Lock Read Write As #FileNum
For i = LBound(parData, 1) To UBound(parData, 1)
locLine = ""
For j = LBound(parData, 2) To UBound(parData, 2)
If IsError(parData(i, j)) Then
locLine = locLine & "#N/A" & parDelimiter
Else
locLine = locLine & parData(i, j) & parDelimiter
End If
Next j
locLine = Left(locLine, Len(locLine) - 1)
If i <> UBound(parData, 1) Then locLine = locLine & vbCrLf
Put #FileNum, , locLine
Next i
error_handler:
Close #FileNum
End Sub
Public Function isArrayEmpty(parArray As Variant) As Boolean
'Returns false if not an array or dynamic array that has not been initialised (ReDim) or has been erased (Erase)
If IsArray(parArray) = False Then isArrayEmpty = True
On Error Resume Next
If UBound(parArray) < LBound(parArray) Then isArrayEmpty = True: Exit Function Else: isArrayEmpty = False
End Function
Public Function getArrayNumberOfDimensions(parArray As Variant) As Long
'Returns the number of dimension of an array - 0 for an empty array.
Dim i As Long
Dim errorCheck As Long
If isArrayEmpty(parArray) Then Exit Function 'returns 0
On Error GoTo FinalDimension
'Visual Basic for Applications arrays can have up to 60000 dimensions
For i = 1 To 60001
errorCheck = LBound(parArray, i)
Next i
'Not supposed to happen
getArrayNumberOfDimensions = 0
Exit Function
FinalDimension:
getArrayNumberOfDimensions = i - 1
End Function
Private Function getDataFromFile(parFileName As String, parDelimiter As String, Optional parExcludeCharacter As String = "") As Variant
'parFileName is supposed to be a delimited file (csv...)
'parDelimiter is the delimiter, "," for example in a comma delimited file
'Returns an empty array if file is empty or can't be opened
'number of columns based on the line with the largest number of columns, not on the first line
'parExcludeCharacter: sometimes csv files have quotes around strings: "XXX" - if parExcludeCharacter = """" then removes the quotes
Dim locLinesList() As Variant
Dim locData As Variant
Dim i As Long
Dim j As Long
Dim locNumRows As Long
Dim locNumCols As Long
Dim fso As Variant
Dim ts As Variant
Const REDIM_STEP = 10000
Set fso = CreateObject("Scripting.FileSystemObject")
On Error GoTo error_open_file
Set ts = fso.OpenTextFile(parFileName)
On Error GoTo unhandled_error
'Counts the number of lines and the largest number of columns
ReDim locLinesList(1 To 1) As Variant
i = 0
Do While Not ts.AtEndOfStream
If i Mod REDIM_STEP = 0 Then
ReDim Preserve locLinesList(1 To UBound(locLinesList, 1) + REDIM_STEP) As Variant
End If
locLinesList(i + 1) = Split(ts.ReadLine, parDelimiter)
j = UBound(locLinesList(i + 1), 1) 'number of columns
If locNumCols < j Then locNumCols = j
If j = 13 Then
j = j
End If
i = i + 1
Loop
ts.Close
locNumRows = i
If locNumRows = 0 Then Exit Function 'Empty file
ReDim locData(1 To locNumRows, 1 To locNumCols + 1) As Variant
'Copies the file into an array
If parExcludeCharacter <> "" Then
For i = 1 To locNumRows
For j = 0 To UBound(locLinesList(i), 1)
If Left(locLinesList(i)(j), 1) = parExcludeCharacter Then
If Right(locLinesList(i)(j), 1) = parExcludeCharacter Then
locLinesList(i)(j) = Mid(locLinesList(i)(j), 2, Len(locLinesList(i)(j)) - 2) 'If locTempArray = "", Mid returns ""
Else
locLinesList(i)(j) = Right(locLinesList(i)(j), Len(locLinesList(i)(j)) - 1)
End If
ElseIf Right(locLinesList(i)(j), 1) = parExcludeCharacter Then
locLinesList(i)(j) = Left(locLinesList(i)(j), Len(locLinesList(i)(j)) - 1)
End If
locData(i, j + 1) = locLinesList(i)(j)
Next j
Next i
Else
For i = 1 To locNumRows
For j = 0 To UBound(locLinesList(i), 1)
locData(i, j + 1) = locLinesList(i)(j)
Next j
Next i
End If
getDataFromFile = locData
Exit Function
error_open_file: 'returns empty variant
unhandled_error: 'returns empty variant
End Function
Despite my personal impression that your code can be improved in some instances, it syntactically executes here with no problem (on small matrices).
My test data
1,2,3 2,3,4 20,26,32
2,3,4 X 3,4,5 = 29,38,47
3,4,5 4,5,6 38,50,62
The result is neatly written to a CSV.
Only obvious problem (here on Win 7 !) is that Sub writeToCsv -> Open parFileName ... fails due to lack of write permissions into the root directory. This might be not a problem on XP.
On a different token, I have the impression the code can be improved, but I may not understand the rationale behind some parts of your code.
examples
Function MMULT2_FUNC(ByRef ADATA_RNG As Variant, ByRef BDATA_RNG As Variant) ' missing type of result
Private Function getDataFromFile(...)
...
If j = 13 Then
j = j
End If ' whow ... if j <> 13 then j again equals j ;-)
finding upper and lower bounds of the matrices on input as well as on output could be simplified by large ...
Thank you all for your help. The reason why my code was not printing results was that I had this:If ANCOLUMNS <> BNROWS Then: GoTo ERROR_LABEL. At the same time, I was using two matrices of 70*120, so it constantly exited the function as I had programmed it to do!!Corrected it all and worked fine. Thanks a lot for your help