I have an Excel sheet with a column containing texts like "Hello there 2005 A" I want to split this text in between two columns, one containing 'Hello there 2005' and the other saying 'A'.
I have tried Split function in VBA, but I can't make it loop through the entire column or even come up with a delimeter which will split exactly before the letter 'A'.
Results should look something like this:
try this
Option Explicit
Sub main()
Dim cell As Range
Dim strng As Variant
Dim rightStrng As String
Dim i As Long
With Worksheets("multimanager") '<== change it as per your needs
For Each cell In .Columns("A").SpecialCells(xlCellTypeConstants, xlTextValues) 'assuming that "column containing texts" is column "A"
strng = Split(cell)
rightStrng = ""
i = UBound(strng)
Do While Not IsNumeric(strng(i)) And i > 0
rightStrng = strng(i) & " " & rightStrng
i = i - 1
Loop
If IsNumeric(strng(i)) Then
rightStrng = Application.WorksheetFunction.Trim(rightStrng)
cell.Offset(, 2) = rightStrng
cell.Offset(, 1) = Left(cell.Value, IIf(rightStrng <> "", InStrRev(cell.Value, rightStrng) - 2, Len(cell.Value)))
End If
Next cell
End With
End Sub
Instr(cellValue," ")
will give you the position of your first space
firstPos = instr(cellValue," ") ' first space
secondPos = instr(firstPos + 1, cellValue, " ") ' second space
etc..
or
followed by mid, and replace
secondColumnValue = mid(cellValue, thirdPos + 1)
firstColumnValue = replace(cellValue, secondColumnValue, "")
Related
In an Excel worksheet there is a title in the first row and there are titles of each column in the second row. The columns titled 'A' and 'B' contain the initial data, and the column titled 'TF' will contain the resulting data (Excel columns A, B and C respectively).
In the following code, the numbers from 1 to 5 on the left are just row headers and are not data in the worksheet.
1 Table
2 A B TF
3 ABC ABC TRUE
4 ABC BAC FALSE
5 #N/A ABC #N/A
What I have tried.
Sub Compare2Col()
Dim colAnum As Integer, colBnum As Integer, loopNum As Integer, i As Integer
Dim holder As Variant
colAnum = Worksheets("Sheet1").Range("A1048576").End(xlUp).Row
colBnum = Worksheets("Sheet1").Range("B1048576").End(xlUp).Row
If colAnum > colBnum Then
loopNum = colAnum
Else
loopNum = colBnum
End If
For i = 3 To loopNum
If Range("A" & i).Value = "" Or Range("B" & i).Value = "" Or Range("A" & i).Value = "#N/A" Or Range("B" & i).Value = "#N/A" Then
Range("C" & i).Value = "#N/A"
Else
If Range("A" & i).Value = Range("B" & i).Value Then
Range("C" & i).Value = True
Else
Range("C" & i).Value = False
End If
End If
Next i
End Sub
This is the code I am trying to work with currently. In some cells I will be having these "#N/A" values. How do I have an if statement so that when it is true, it just places the same "#N/A" value into the third column.
I read that these #N/A values are errors. So in VBA I placed a #N/A value into a variable in the following way:
holder = Range("A" & 5).Value
The result of the 'holder' variable was 'Error 2042'.
Thanks in advance. Really appreciate any help!
Handling the infamous VBA Errors (2042) successfully!?
Before using this code be sure you have studied at least the customize section carefully or you might lose data.
Most importantly the second column must always be adjacent to the right of the first column, otherwise this code couldn't have been done with the 'array copy-paste version'.
#Melbee: I am assuming you have your initial data in columns A
ciFirstCol
and B iSecondCol = ciFirstCol + 1 and the result should be in column C cCOff 'if 1 then first column next to the second column. If not make changes in the customize section.
Option Explicit
'-------------------------------------------------------------------------------
Sub XthColumnResult()
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Description
'In an Excel worksheet uses two adjacent columns of initial data as arguments
'for a function whose result is pasted into a third column anywhere to the
'right of the two initial columns.
'(In short: 2 cols of data, perform calculation, result in third column)
'Arguments as constants
'cWbName
'The path of the workbook, if "" then ActiveWorkbook
'cWsName
'Name of the worksheet, if "" then ActiveSheet
'cloFirstRow
'First row of data
'ciFirstCol
'First column of data
'cCOff
'Column offset, where to paste the results into.
'Returns
'The resulting data in a new column to the right of the two initial adjacent
'columns of data.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'-- CUSTOMIZE BEGIN --------------------
Const cWbName As String = "" 'Workbook Path (e.g. "C:\MyExcelVBA\Data.xls")
Const cWsName As String = "" 'Worksheet Name (e.g. "Sheet1", "Data",... etc.
Const cloFirstRow As Long = 3 'First Row of Data
'Const cloLastRow as Long = Unknown >therefore> Dim loRow as Long
Const ciFirstCol As Integer = 1 'First Column of Data (1 for A, 2 for B etc.
'Second column of data must be adjacent to the right of first column.
'See iSecondCol. Therefore Dim iSecondCol As Integer
'Column offset where to paste the results into. Default is 1 i.e. the first
'column next to the second column.
Const cCOff As Integer = 1
'-- CUSTOMIZE END ----------------------
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Variables
Const cStrVBAError As String = "Error 20" 'Debug VBA Error Variable
Const cStrVBAErrorMessage As String = "Not Possible." 'Debug VBA Error Message
Dim oWb As Workbook
Dim oWs As Worksheet
Dim oRng As Range
Dim TheArray() As Variant
Dim SmallArray() As Variant
Dim loRow As Long 'Last Row of Data
Dim iSecondCol As Integer 'Second Column of Data
Dim iF1 As Integer 'Column Counter
Dim loArr As Long 'Array Row Counter
Dim iArr As Integer 'Array Column Counter
Dim str1 As String 'Debug String
Dim str2 As String 'Debug Helper String
Dim varArr As Variant 'Helper Variable for the Array
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Determine workbook and worksheet
If cWbName = "" Then
Set oWb = ActiveWorkbook
Else
Set oWb = Workbooks(cWbName)
End If
If cWsName = "" Then
Set oWs = oWb.ActiveSheet
Else
Set oWs = oWb.Worksheets(cWsName)
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Calculate second column of data
iSecondCol = ciFirstCol + 1
'Calculate last row of data (the greatest row of all columns)
loRow = 0
'Trying to translate the code to English:
'For each column go to the last cell and press crtl+up which is the last
'cell used in that column and use the row property...
For iF1 = ciFirstCol To iSecondCol
'...and check if it is greater than loRow.
If loRow < oWs.Cells(Rows.Count, ciFirstCol + iF1 - 1).End(xlUp).Row Then
'Assign the row to loRow (if it is greater than loRow).
loRow = oWs.Cells(Rows.Count, ciFirstCol + iF1 - 1).End(xlUp).Row
End If
Next
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Status
'The last row of data has been calculated. Additionally the first row, the
'first column and the second column will be the arguments of the following
'range (to be assigned to an array).
'Remarks
'When performing calculation, objects like workbooks, worksheets, ranges are
'usually very slow. To speed up, an array is introduced to hold the data
'and to calculate from there which is dozens of times faster.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Assign the range of data to an array.
TheArray = oWs.Range(Cells(cloFirstRow, ciFirstCol), Cells(loRow, iSecondCol))
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Status
'All data is now in TheArray ready for calculation.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' str1 = "Initial Contents in TheArray"
' For loArr = LBound(TheArray, 1) To UBound(TheArray, 1)
' For iArr = LBound(TheArray, 2) To UBound(TheArray, 2)
' If iArr > 1 Then
' str1 = str1 & Chr(9) 'Next Column
' Else 'First run-though.
' str1 = str1 & vbCrLf 'Next Row
' End If
' If Not IsError(TheArray(loArr, iArr)) Then
' str1 = str1 & TheArray(loArr, iArr)
' Else
' str1 = str1 & VbaErrorString(TheArray(loArr, iArr))
' End If
' Next
' Next
' Debug.Print str1
' str1 = ""
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Remarks
'A one-based array is needed to be pasted into the worksheet via range.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Create a new array for the resulting column.
ReDim SmallArray(LBound(TheArray) To UBound(TheArray), 1 To 1)
'Calculate values of the resulting column.
For loArr = LBound(TheArray, 1) To UBound(TheArray, 1)
'Read values from TheArray and calculate.
If IsError(TheArray(loArr, 1)) Then 'First column error
'VBA Error Handling, the result if both columns contain an error.
varArr = VbaErrorString(TheArray(loArr, 1))
Else
If IsError(TheArray(loArr, 2)) Then 'Second column error
'VBA Error Handling
varArr = VbaErrorString(TheArray(loArr, 2))
Else
If TheArray(loArr, 1) = "" Or TheArray(loArr, 2) = "" Then '""
varArr = "#N/A"
Else
Select Case TheArray(loArr, 1) 'Equal
Case TheArray(loArr, 2)
varArr = True
Case Is <> TheArray(loArr, 2) 'Not equal
varArr = False
Case Else
varArr = "UNKNOWN ERROR" 'Should never happen.
End Select
End If
End If
End If
'Write the results to SmallArray.
SmallArray(loArr, 1) = varArr
Next
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Status
'The resulting column containing the results has been written to SmallArray.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' str1 = "Resulting Contents in SmallArray"
' For loArr = LBound(SmallArray, 1) To UBound(SmallArray, 1)
' If Not IsError(SmallArray(loArr, 1)) Then
' str1 = str1 & vbCrLf & SmallArray(loArr, 1)
' Else
' 'VBA Error Handling
' str1 = str1 & vbCrLf & VbaErrorString(SmallArray(loArr, 1))
' End If
' Next
' Debug.Print str1
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Calculate the range where to paste the data,
Set oRng = oWs.Range(Cells(cloFirstRow, iSecondCol + 1), _
Cells(loRow, iSecondCol + 1))
'Paste the resulting column to worksheet.
oRng = SmallArray
' str1 = "Results of the Range"
' For loArr = 1 To oRng.Rows.Count
' If Not IsError(oRng.Cells(loArr, 1)) Then
' str2 = oRng.Cells(loArr, 1)
' Else
' 'VBA Error Handling
' str2 = VbaErrorCell(oRng.Cells(loArr, 1))
' End If
' str1 = str1 & vbCrLf & str2
' Next
' Debug.Print str1
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Status
'The resulting data has been pasted from SmallArray to the resulting
'column in the worksheet.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
End Sub
'-------------------------------------------------------------------------------
Function VbaErrorCell(rCell As Range) As String
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Description
'Converts a VBA error (variant) IN A RANGE to an Excel error value (string).
'Arguments
'rCell
'A cell range with a possible VBA error.
'If cell range contains more than one cell, the first cell is used.
'Returns
'An Excel error value (string) if the cell contains an error value, "" if not.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Const cVErrLeft As String = "Error 20" 'Debug VBA Error Variable
Const cStrNewError As String = "New Error. Update this Function!"
Const cStrNoError As String = ""
''''''''''''''''''''''''''''''''''''''''
Dim strCStr As String 'The rCell Value Converted to a String
Dim strRes As String 'One of the Excel Cell Error Values
''''''''''''''''''''''''''''''''''''''''
strCStr = Left(CStr(rCell(1, 1)), Len(cVErrLeft))
If strCStr = cVErrLeft Then
Select Case Right(CStr(rCell), 2)
Case "00": strRes = "#NULL!"
Case "07": strRes = "#DIV/0!"
Case "15": strRes = "#VALUE!"
Case "23": strRes = "#REF!"
Case "29": strRes = "#NAME?"
Case "36": strRes = "#NUM!"
Case "42": strRes = "#N/A"
Case Else: strRes = cStrNewError 'New Error.
End Select
Else
strRes = cStrNoError 'Not a VBA Error
End If
VbaErrorCell = strRes
''''''''''''''''''''''''''''''''''''''''
End Function
'-------------------------------------------------------------------------------
Function VbaErrorString(strString As Variant) As String
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Description
'Converts a VBA error (variant) IN A STRING to an Excel error value (string).
'Arguments
'strString
'A string with a possible VBA Error.
'Returns
'An Excel error value (string) if the cell contains an error value, "" if not.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Const cVErrLeft As String = "Error 20" 'Debug VBA Error Variable
Const cStrNewError As String = "New Error. Update this Function!"
Const cStrNoError As String = ""
''''''''''''''''''''''''''''''''''''''''
Dim strCStr As String 'The strString Value Converted to a String
Dim strRes As String 'One of the Excel Cell Error Values
''''''''''''''''''''''''''''''''''''''''
strCStr = Left(CStr(strString), Len(cVErrLeft))
If strCStr = cVErrLeft Then
Select Case Right(CStr(strString), 2)
Case "00": strRes = "#NULL!"
Case "07": strRes = "#DIV/0!"
Case "15": strRes = "#VALUE!"
Case "23": strRes = "#REF!"
Case "29": strRes = "#NAME?"
Case "36": strRes = "#NUM!"
Case "42": strRes = "#N/A"
Case Else: strRes = cStrNewError 'New Error.
End Select
Else
strRes = cStrNoError 'Not a VBA Error
End If
VbaErrorString = strRes
''''''''''''''''''''''''''''''''''''''''
End Function
'-------------------------------------------------------------------------------
Additionally in view of automation to update the cells automatically, you might want to put the following code into the sheets code window:
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
XthColumnResult
End Sub
The ideal solution should be with the Change event, but it throws the 'Run-time error 28: Out of stack space', so I used the SelectionChange event instead.
The only drawback I could find was that when you delete a cell with 'del' the value in the third column isn't updated before you move out of the cell.
As always sorry for the 'overcommenting'.
Try using IsEmpty and IsError
For i = 1 To loopNum
If IsEmpty(Range("A" & i)) Or IsEmpty(Range("B" & i)) Or IsError(Range("A" & i)) Or IsError(Range("B" & i)) Then
Range("C" & i).Value = "#N/A"
Else
If Range("A" & i).Value = Range("B" & i).Value Then
Range("C" & i).Value = True
Else
Range("C" & i).Value = False
End If
End If
Next i
Assuming there isn't a reason you actually need to do this in VBA (since you haven't included any code with your question) all you need is a simple worksheet formula.
If Columns A and B contain the data you need to compare, starting on row 3 (like your example implies), enter this formula in Cell C3:
=IF(A3&B3="","",A3=B3)
...then copy/paste (of "fill down") the formula as far as necessary.
If the concatenated values of columns A & B are blank it returns an empty string ("") otherwise it returns the comparison of columns A & B (TRUE or FALSE).
Incidentally if not for the requirement to "return nothing if blank" then the formula would have been about as simple as they get:
=A3=B3
I have one array with Sheet Names called SheetNames and I want to generate a sub array of it that only returns True at the condition (IF). I try to have a loop into a cell value onto different sheets, evaluating condition cell.value = "S". When checks that for the first D column (z = 4) I want to make the same check (IF condition) for columns D to DR at the same row.
I need to get similar result if I use formula at
Diary!C7
= IF (element!D6 = "S",CONCATENATE (element!B1, ", "), ""),
IF (element1!D6 = "S",CONCATENATE (element1!B1, ", "), ""), ....
IF (element!E6 = "S",CONCATENATE (element!B1, ", "), ""),
IF (element1!E6 = "S",CONCATENATE (element1!B1, ", "), "") .... )
Where element is a sheet name taken from an array with the sheet names who get the condition (Code S or another code).
SheetNames is one array with all the book sheets and FSheet (Filtered Sheet with condition) an array with only the filtered (with condition IF). When I can populate FSheet array for each sheet I test the condition then I must concatenate it's values at another sheet/cell and began the test condition again to the next cell (E6) ... But I'm trapped at the step to create FSheet.
Sub Test()
Dim ws As Worksheet
Dim SheetNames() As String, FSheets() As String, q As String
Dim element As Variant
Dim lastSheet As Integer, r As Integer, incrSheet As Integer, i As Integer
Dim Rgn As Range
' Enter the sheet names into an array. Redim array's size to the number of sheets (lastSheet)
For Each ws In ActiveWorkbook.Worksheets
ReDim Preserve SheetNames(lastSheet)
SheetNames(lastSheet) = ws.name
lastSheet = lastSheet + 1
Next ws
MsgBox lastSheet
' Test condition for each sheet/cell
For z = 4 To 11
For Each element In SheetNames()
incrSheet = 1
If ActiveWorkbook.Sheets(element).Cells(6, z).Value = "S" Then
ReDim Preserve FSheets(incrSheet)
FSheets(incrSheet) = element
incrSheet = incrSheet + 1
End If
Next element
Next z
i = 3
' Define the sheet to work (total project will have more than one, one for code we need test, S, C, etc)
With Worksheets("Diary")
.Activate
.Range("C7").Select
' Concatenate values at Summary page
Do
Cells(7, i).Select
For r = 1 To UBound(FSheets)
'Concatenate with &:
varConctnt = varConctnt & ", " & FSheets(r)
Next r
'remove the "&" before the first element:
varConctnt = Mid(varConctnt, 2)
q = varConctnt
varConctnt = ""
i = i + 1
ActiveCell.Value = q
Loop While i < 11
' Drag the formula for the rest of the rows
Range("C7:J7").Select
Selection.AutoFill Destination:=Range("C7:J12"), Type:=xlFillDefault
End With
End Sub
Where you are going wrong, is your attempt to dynamically set the range. Assuming you are testing the value of a single cell, it is much easier to use Cells, rather than Range, since you can use R1C1 notation. Try something like this:
incrSheet = 1
For z = 4 To 11
For Each element In SheetNames()
If ActiveWorkbook.Sheets(element).Cells(6, z).Value = "S" Then
ReDim Preserve FSheets(incrSheet)
FSheets(incrSheet) = element
MsgBox incrSheet
incrSheet = incrSheet + 1
End If
Next element
Next z
My spreadsheet has a column with value like this string:
some text (text1) some test (text2) (text1)
How do I get all values between parentheses? The result I am looking for is:
text1, text2
Even if text1, text2... testn is present in the cell multiple times, I need it in the result only once.
I found a function GetParen here: Get the value between the brackets
It is helpful, but it gives the fist available value in the parentheses and ignores the rest.
It seems unwieldy to have one User Defined Function for individual entries and another for a collective result of all entries.
Paste the following into a standard module code sheet.
Function getBracketedText(str As String, _
Optional pos As Integer = 0, _
Optional delim As String = ", ", _
Optional dupes As Boolean = False)
Dim tmp As String, txt As String, a As Long, b As Long, p As Long, arr() As Variant
tmp = str
ReDim arr(1 To 1)
For b = 1 To (Len(tmp) - Len(Replace(tmp, Chr(40), vbNullString)))
p = InStr(p + 1, tmp, Chr(40))
txt = Trim(Mid(tmp, p + 1, InStr(p + 1, tmp, Chr(41)) - (p + 1)))
If UBound(Filter(arr, txt, True)) < 0 Or dupes Then '<~~ check for duplicates within the array
a = a + 1
ReDim Preserve arr(1 To a)
arr(UBound(arr)) = txt
End If
Next b
If CBool(pos) Then
getBracketedText = arr(pos)
Else
getBracketedText = Join(arr, delim)
End If
End Function
Use like any other native worksheet function. There are optional parameters to retrieve an individual element or a collection as well as changing the default <comma><space> delimiter.
This code works for me:
Sub takingTheText()
Dim iniP 'first parenthesis
Dim endP 'last parentehis
Dim myText 'the text
Dim txtLen
Dim i
Dim tmp
Dim j
myText = Range("A1").Value
txtLen = Len(myText)
j = 0
Do 'Loop in the text
i = i + 1 'a counter
iniP = InStr(1, myText, "(", 1) 'found the first occurence of the (
endP = InStr(1, myText, ")", 1) 'same as above
tmp = tmp & Right(Left(myText, i), 1) 'take the text garbage text
If i = iniP Then 'here comes the work
j = j + 1 'here take the cell index
myText = Replace(myText, tmp, "") 'remove the garbage text in front the first (
tmp = Left(myText, endP - iniP - 1) 'reuse the var to store the usefull text
Cells(1, 2).Value = Cells(1, 2).Value & Chr(10) & tmp 'store in the cell B1
'If you want to stored in separated cells use the below code
'Cells(j, 2).Value = tmp
myText = Replace(myText, tmp & ")", "", 1, 1) ' remove the garbage text from the main text
tmp = Empty 'empty the var
i = 0 'reset the main counter
End If
Loop While endP <> 0
End Sub
Result:
Please check and tellme if is ok.
Edit#1
Cells(1, 2).Value = Cells(1, 2).Value & Chr(10) & tmp this code store the text in separated lines inside the same cell, may be you want to use spaces between the resulting text because of chr(10) (also you can use chr(13)), then you can use Cells(1, 2).Value = Cells(1, 2).Value & " " & tmp, or use any other character instead the string inside the & symbols
I'm working on a 5 sheet workbook, where a button named ExportCSV on sheet 5 exports data on sheet 3. More specifically, the button runs a VBA code that goes row by row and checks the first 3 cells for data. If any of the first three cells have data, then the whole row is selected. After all rows with data are selected, the data is written row by row to a CSV file (the file itself is semicolon-delimited, however).
The problem that I'm having is that some cell formatting is being copied over, but some is not. For example, values in cells formatted for Accounting with a $ are formatted correctly, meaning "$12,345,678.90" shows up as "$12,345,678.90." However, values in cells formatted as Accounting but without $ are not being written to the csv correctly, meaning "12,345,678.90" is being written as "12345678.9."
Below is the Macro in question.
Dim planSheet As Worksheet
Dim temSheet As Worksheet
Private Sub ExportCSV_Click()
Dim i As Integer
Dim j As Integer
Dim lColumn As Long
Dim intResult As Integer
Dim strPath As String
On Error GoTo Errhandler
Set temSheet = Worksheets(3)
i = 2
Do While i < 1001
j = 1
Do While j < 4
If Not IsEmpty(temSheet.Cells(i, j)) Then
temSheet.Select
lColumn = temSheet.Cells(2, Columns.Count).End(xlToLeft).Column
temSheet.Range(temSheet.Cells(2, 1), temSheet.Cells(i, lColumn)).Select
End If
j = j + 1
Loop
i = i + 1
Loop
Application.FileDialog(msoFileDialogFolderPicker).InitialFileName = Application.ActiveWorkbook.Path
Application.FileDialog(msoFileDialogFolderPicker).Title = "Select a Path"
Application.FileDialog(msoFileDialogFolderPicker).ButtonName = "Select Path"
intResult = Application.FileDialog(msoFileDialogFolderPicker).Show
If intResult <> 0 Then
'dispaly message box
strPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
End If
Dim X As Long, FF As Long, S() As String
ReDim S(1 To Selection.Rows.Count)
For X = 1 To Selection.Rows.Count
S(X) = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(Selection.Rows(X).Value)), ";")
Next
FF = FreeFile
FilePath = strPath & "\Data" & Format(Now(), "yyyyMMddhhmmss") & ".csv"
Open FilePath For Output As #FF
Print #FF, Join(S, vbNewLine)
Close #FF
Errhandler:
...Error Handling Code omitted
End Sub
I need to be able to copy over the exact formatting of the cells. Converting the no-$ cells to $ cells won't work because the values without $ are being used for a calculation later on in the process that can handle the commas, but not a $, and I can't change the code for the later calculation (proprietary plug-in doing the calculation.) Also, the rows have mixed content, meaning some values in the row are text instead of numbers.
I ended up following David Zemens' advice and overhauled the section that was For X = 1 to Selection.Rows.Count See below.
For X = 1 To Selection.Rows.Count
For Y = 1 To Selection.Columns.Count
If Y <> Selection.Columns.Count Then
If IsNumeric(temSheet.Cells(X + 1, Y).Value) Then
If temSheet.Cells(X + 1, Y).Value = 0 Then
S(X) = S(X) & ";"
Else
S(X) = S(X) & Replace(temSheet.Cells(X + 1, Y).Text, " ", "") & ";"
End If
Else
S(X) = S(X) & Trim(temSheet.Cells(X + 1, Y).Text) & ";"
End If
Else
If IsNumeric(temSheet.Cells(X + 1, Y).Value) Then
If temSheet.Cells(X + 1, Y).Value <> 0 Then
S(X) = S(X) & Replace(temSheet.Cells(X + 1, Y).Text, " ", "")
End If
Else
S(X) = S(X) & Trim(temSheet.Cells(X + 1, Y).Text)
End If
End If
Next
Next
Some more formatting was necessary. It goes cell by cell, purposefully skipping the first row of the sheet. The .Text property of some of the cells returned empty space before the value or between the $ and value, so it had to be removed. Trim removes leading and ending spaces while Replace replaces all spaces in the export.
Where I work we keep a list of vehicles that we find with damages. These damage codes come in a few variations, and I would like to setup a VBA script in excel to auto change the contents of a cell with the correct formatting, but I don’t really use VBA scripting and the Excel data objects confuse me
Here are a few examples of what I would like
06071 – VBA Function – 06.07.1
031211 – VBA Function- 03.12.1(1)
0409237-VBA Function – 04.09.2(3,7)
040912 030713 –VBA Function – 04.09.1(2) 03.07.1(3) (some vehicles have multiple damages)
Basically any number past length 5 would put any numbers in the 6th position onward into the parentheses, separated by commas.
I could do this in just about any other language, it’s just with all the random Excel stuff I am having issue after issue.
It doesn’t seem to matter what I try, my code bugs out before I can make any progress past
Dim test
test = Worksheets(“Sheet1”).Range(“A:A”).Value
Worksheets(“Sheet2”).Range(“B:B”).Value=test
I tried to make a function which ended up not working no matter how I called it. If I could just basic formatting of these numbers, I could more than likely figure it out from there.
Thanks for any help you guys can give me
You can do this with a UDF (user defined function): Place the following code in a new module in VBA:
Function ConvertIt(rng As Range) As String
Dim varStr As Variant
Dim strSource As String, strResult As String
Dim i As Integer
For Each varStr In Split(Trim(rng.Value), " ")
strSource = CStr(varStr)
strResult = strResult & _
Mid(strSource, 1, 2) & "." & _
Mid(strSource, 3, 2) & "." & _
Mid(strSource, 5, 1)
If Len(strSource) > 5 Then
strResult = strResult & "("
For i = 6 To Len(strSource)
strResult = strResult & Mid(strSource, i, 1) & ","
Next i
strResult = Left(strResult, Len(strResult) - 1) & ")"
End If
strResult = strResult & " "
Next
ConvertIt = Left(strResult, Len(strResult) - 1)
End Function
Assuming that your data is in column A of your worksheet, place this formula in B2: =ConvertIt(A2) and copy it down. Done!
If you want to convert the cells in one rush and replace the source, use this code:
Sub ConvertAll()
Dim rng As Range
For Each rng In Range("A1:A100")
rng.Value = ConvertIt(rng)
Next
End Sub
Lightly-tested:
Function FormatStuff(v)
Dim i As Long, c As String, v2 As String, num As String
Dim num2 As String, x As Long
v2 = v
v = v & " "
For i = 1 To Len(v)
c = Mid(v, i, 1)
If c Like "#" Then
num = num & c
Else
If num <> "" And Len(num) >= 5 Then
num2 = Left(num, 2) & "." & Mid(num, 3, 2) & _
"." & Mid(num, 5,1)
If Len(num) > 5 Then
num2 = num2 & "("
For x = 6 To Len(num)
num2 = num2 & IIf(x > 6, ",", "") & Mid(num, x, 1)
Next x
num2 = num2 & ")"
End If
v2 = Replace(v2, num, num2)
End If
num = ""
End If
Next i
FormatStuff = v2
End Function
To answer your unasked question:
There are two reasons the code you supplied does not work.
Range("A:A") and Range("B:B") both select entire rows, but the
test variable can only hold content for one cell value at a time.
If you restrict your code to just one cell, using
Range("A1").value, for example, the code you have written will
work.
It seems you used different quotation marks than the
standard, which confuses the compiler into thinking "Sheet1", "A:A". etc. are variables.
With the range defined as one cell, and the quotation marks replaced, your code moves the value of cell A1 on Sheet1 to cell B1 on Sheet2:
Sub testThis()
Dim Test
Test = Worksheets("Sheet1").Range("A1").value
Worksheets("Sheet2").Range("B1").value = Test
End Sub
If you wanted to work down the entire column A on Sheet1 and put those values into the column B on Sheet2 you could use a loop, which just repeats an action over a range of values. To do this I've defined two ranges. One to track the cells on Sheet1 column A, the other to track the cells on Sheet2 column B. I've assumed there is no break in your data in column A:
Sub testThat()
Dim CellinColumnA As Range
Set CellinColumnA = Worksheets("Sheet1").Range("A1")
Dim CellinColumnB As Range
Set CellinColumnB = Worksheets("Sheet2").Range("B1")
Do While CellinColumnA.value <> ""
CellinColumnB.value = CellinColumnA.value
Set CellinColumnA = CellinColumnA.Offset(1, 0)
Set CellinColumnB = CellinColumnB.Offset(1, 0)
Loop
End Sub