VBA Excel replace line breaks in a cell - vba

I would need to replace the line breaks in a cell, with a line break and the content of a cell in the same column of the active cell.
The code would be something like this:
For i = LBound(arColumns) To UBound(arColumns)
'ActiveColumn = arColumns(i)
Set rng = Range(arColumns(i))
For Each Cell In rng.Cells
If Cell.row > 4 And Cell.row < r Then
colnum=cell.column
Cell.value = "{Something}" & Cells(3, colnum).value & _
", text here{/something}" & Cell.value 'First line in the cell
cell.replace what:=vbCrLf, replacement:=vbCrLf & "{Something}" & _
Cells(3, colnum).value & ", text here{/something}" 'First try
Cell.value = Application.WorksheetFunction.Substitute(CStr(Cell.value), vbCrLf, vbCrLf & _
"{maxlen}{/maxlen}{notes}" & ", No Max length{/notes}") 'Second try
End If
Next
Next
I've tried to replace the values of the line breaks with the two methods, replace and substitute. None of them have been working or I am doing something wrong with this block of code.
The array arColumns have the range of columns that I want to work, for example: B:C,E:E,M:O,Z:AB...

along with the vbLf fix you've already been told, you could refactor your code as follows:
Option Explicit
Sub main()
Dim arColumns As Variant
Dim cell As Range
Dim r As Long, i As Long
arColumns = Array("B:C", "E:E", "M:O", "Z:AB")
r = 10 '<--| just to have a value to test with
For i = LBound(arColumns) To UBound(arColumns)
For Each cell In Intersect(Range(arColumns(i)), Rows("4:" & r)).SpecialCells(xlCellTypeConstants) '<--| loop through current columnns group not empty cells from row 4 to 'r'
cell.Replace what:=vbLf, replacement:=vbLf & "{Something}" & Cells(3, cell.Column).Value & ", text here{/something}" 'First try
Next
Next
End Sub

Related

VBA Testing two values, if one is different, copy

I am having a fair amount of trouble with the code below:
Sub TestEmail()
Dim i As Long
Dim LastRow As Long
Dim a As Worksheet
Dim b As Worksheet
Dim strText
Dim ObjData As New MSForms.DataObject
Set a = Workbooks("Book2").Worksheets(1)
Set b = Workbooks("Book1").Worksheets(1)
LastRow = a.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
If Not IsError(Application.Match(a.Cells(i, 7).Value, b.Columns(3), 0)) And IsError(Application.Match(a.Cells(i, 4).Value, b.Columns(11), 0)) Then
a.Range("D" & i).Copy
ObjData.GetFromClipboard
strText = Replace(ObjData.GetText(), Chr(10), "")
b.Range("K" & ).Value = b.Range("K" & ).Value & " / " & strText
End If
Next i
End Sub
I face two problems, one has me stumped and the other is due to lack of knowledge:
The line after IF is supposed to check if two values (numbers) in both workbooks match, and if two other values (text) don't match. If all true, then it must copy a value from Book2 and add it to a cell in book1.
The problems are:
-The macro doesn't seem to recognise when the values match or not.
-In the last line before "End If", I don't know how to tell excel to copy the text into the cell that didn't match in the second check.
I am sorry if I am not clear enough, this is hard to explain.
I'm hoping one of the experts knows how to make this work.
Thanks in advance
You are using If Not condition 1 And condition 2, so you are saying that if it doesn't match both conditions, Then you run the code. What you want to make are Nested If Statements However, one is If and the other If Not
To copy you are missing the i After "K"&: b.Range("K" & i) = b.Range("K" & i).Value & " / " & strText
The Address of the Cells are inside the Range Function, which in your case would be:
//It is the cell of the email from the first Workbook tou are copying, where you input the column D
a.Range("D" & i).Copy
//Add to Workbook b in column K the value from Cell K#/value copied
b.Range("K" & i) = b.Range("K" & i).Value & " / " & strText
You can also make it like this: b.Range("K" & i) = b.Range("K" & i).Value & " / " & a.Range("D" & i)
This way you are matching lines, so only if the IDs are on the same rows on both Workbooks it will work. If they aren't, you will have to use Nesting Loops or .Find Function
EDIT:
If I understood it, the code below might work if you make some changes for your application, because i didn't have the data to test and columns, etc. Try to implement it.
LastRowa = a.Cells(Rows.Count, "A").End(xlUp).Row
LastRowb = b.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRowa
'Address of String to look for
LookForString = a.Worksheets(1).Cells(i, 4) '4 is the COLUMN_INDEX
'Range to look on Workbook a
With a.Worksheets(1).Range("D1:D" & LastRowa) 'choose column to look
'Function .Find String on book a
Set mail_a = .Find(LookForString, LookIn:=xlValues)
If Not mail_a Is Nothing Then
FirstAddress = mail_a.Address
Do ' Actions here
'Range to look on Workbook b
With b.Worksheets(1).Range("K1:K" & LastRowb) 'choose column to look
'Function .Find on Workbook b
Set mail_b = .Find(LookForString, LookIn:=xlValues)
If Not mail_b Is Nothing Then
FirstAddress = mail_b.Address
Do 'Actions
'Verify if two other values (text) don't match
If Not WRITE_MATCH_CONDITION_HERE Then
'No need to verify of they are equal because the .Find function used the same reference
'I will use .Cells with .Row and .Column just to show another way to do it and make it dynamic
b.Cells(mail_b.Adress.Row, mail_b.Adress.Column) = b.Cells(mail_b.Adress.Row, mail_b.Adress.Column).Value & " / " & a.Cells(mail_a.Adress.Row, mail_a.Adress.Column) 'choose columns
End If
Set mail_b = .FindNext(mail_b)
Loop While Not mail_b Is Nothing And mail_b.Address <> FirstAddress
End If
End With
Set mail_a = .FindNext(mail_a)
Loop While Not mail_a Is Nothing And mail_a.Address <> FirstAddress
End If
End With
Next i
End Sub
p.s.: The <> is missing on mail_a.Address <> FirstAddress and mail_b.Address <> FirstAddress, when i posted with

Enquoting a cell value in double quotes: Excel VBA Macro

I want to put double quotes inside all cells in a particular column.
I have wrote the code to put double quotes but the problem is it is putting 3 double quotes around the value.
For Each myCell In ActiveWorkbook.Sheets("Sheet1").Range("B:B")
If myCell.Value <> "" Then
myCell.Value = Chr(34) & myCell.Value & Chr(34)
End If
Next myCell
The basic requirement is to split the excel file according to column B and save them as CSV files.
In the split filed, the values of column B and D must be enclosed within double quotes.
Full Code :
Option Explicit
Sub ParseItems()
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String, SvPath As String
Dim myCell As Range, transCell As Range
'Sheet with data in it
Set ws = Sheets("Sheet1")
'Path to save files into, remember the final \
SvPath = "D:\SplitExcel\"
'Range where titles are across top of data, as string, data MUST
'have titles in this row, edit to suit your titles locale
'Inserting new row to act as title, copying the data from first row in title, row deleted after use
ws.Range("A1").EntireRow.Insert
ws.Rows(2).EntireRow.Copy
ws.Range("A1").Select
ws.Paste
vTitles = "A1:Z1"
'Choose column to evaluate from, column A = 1, B = 2, etc.
vCol = 2
If vCol = 0 Then Exit Sub
'Spot bottom row of data
LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row
'Speed up macro execution
Application.ScreenUpdating = False
'Get a temporary list of unique values from key column
ws.Columns(vCol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("EE1"), Unique:=True
'Sort the temporary list
ws.Columns("EE:EE").Sort Key1:=ws.Range("EE2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
'Put list into an array for looping (values cannot be the result of formulas, must be constants)
MyArr = Application.WorksheetFunction.Transpose(ws.Range("EE2:EE" & Rows.Count).SpecialCells(xlCellTypeConstants))
'clear temporary worksheet list
ws.Range("EE:EE").Clear
'Turn on the autofilter, one column only is all that is needed
'ws.Range(vTitles).AutoFilter
'Loop through list one value at a time
For Itm = 1 To UBound(MyArr)
ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)
'transCell = ws.Range("A2:A" & LR)
ws.Range("A2:A" & LR).EntireRow.Copy
Workbooks.Add
Range("A1").PasteSpecial xlPasteAll
Cells.Columns.AutoFit
MyCount = MyCount + Range("A" & Rows.Count).End(xlUp).Row - 1
For Each myCell In ActiveWorkbook.Sheets("Sheet1").Range("B:B")
If myCell.Value <> "" Then
myCell.Value = Chr(34) & myCell.Value & Chr(34)
End If
Next myCell
ActiveWorkbook.SaveAs SvPath & "po" & MyArr(Itm) & ActiveWorkbook.Sheets("Sheet1").Range("D1") & "." & Date2Julian(Date), xlCSV, local:=False
ActiveWorkbook.Close False
ws.Range(vTitles).AutoFilter Field:=vCol
Next Itm
'Cleanup
ws.Rows(1).EntireRow.Delete
ws.AutoFilterMode = False
Application.ScreenUpdating = True
End Sub
Function Date2Julian(ByVal vDate As Date) As String
Date2Julian = Format(DateDiff("d", CDate("01/01/" _
+ Format(Year(vDate), "0000")), vDate) _
+ 1, "000")
End Function
Sample Input Data :
24833837 8013 70 1105
25057089 8013 75 1105
25438741 8013 60 1105
24833837 8014 70 1106
25057089 8014 75 1106
25438741 8014 60 1106
Expected Output is Two files created with following data
File 1 :
24833837,"8013",70,1105
25057089,"8013",75,1105
25438741,"8013",60,1105
File 2:
24833837,"8014",70,1106
25057089,"8014",75,1106
25438741,"8014",60,1106
Resultant Output :
File 1 :
24833837,"""8013""",70,1105
25057089,"""8013""",75,1105
25438741,"""8013""",60,1105
Same for File 2
Kindly help. :)
Afaik, there is no simple way to trick Excel into using quotes around numbers when using the normal "save as csv"-procedure. You can, however, use VBA to save in whatever csv format you like.
Take code example from https://support.microsoft.com/en-us/help/291296/procedure-to-export-a-text-file-with-both-comma-and-quote-delimiters-in-excel
Just add an if-statement to determine whether to use quotes or not
' Write current cell's text to file with quotation marks.
If WorksheetFunction.IsText(Selection.Cells(RowCount, ColumnCount)) Then
Print #FileNum, """" & Selection.Cells(RowCount, _
ColumnCount).Text & """";
Else
Print #FileNum, Selection.Cells(RowCount, _
ColumnCount).Text;
End If
The WorksheetFunction.IsText will recognize your numbers as text if they are entered with a preceding ' (single high quote)
You would need to adjust the example to export the range you want with the pre-given filename from your code.
This little sub will do as you need. Just give it a filename fname, range to export as csv rg and a column number column_with_quotes - so something like this but with a range to suit:
save_as_csv_with_optional_quotes SvPath & "po" & MyArr(Itm) & ActiveWorkbook.Sheets("Sheet1").Range("D1") & "." & Date2Julian(Date), Range("A1:C5"), 2
Here is the sub:
Sub save_as_csv_with_optional_quotes(fname As String, rg As Range, column_with_quotes As Long)
Dim ff, r, c As Long
Dim loutput, cl As String
ff = FreeFile
Open fname For Output As ff
For r = 1 To rg.Rows.Count
loutput = ""
For c = 1 To rg.Columns.Count
If loutput <> "" Then loutput = loutput & ","
cl = rg.Cells(r, c).Value
If c = column_with_quotes Then cl = Chr$(34) & cl & Chr$(34)
loutput = loutput & cl
Next c
Print #ff, loutput
Next r
Close ff
End Sub
the problem is this line.
myCell.Value = Chr(34) & myCell.Value & Chr(34)
The quotes you are adding are then being quoted again when you export as CSV, hence three quotes each side of the value. A better option I think would be to change the number format of the myCell to be Text, rather than number. I haven't tried this but I think changing it to this should help.
myCell.Value = Chr(39) & myCell.Value
Chr(39) is an apostrophe and when you enter it as the first character of a cell value it forces the format to be Text.

Dyanmic VBA code for changing the vba when a sheet name is changed

I have a vba code which specifies particular sheet names to look at for example sheet 2,
But what if, someone forgot to change the sheet name to sheet2, can I add a piece of dynamic code to automatically change the vba code for which ever the sheet name is called? for example the second sheet in from the left.
Code Module 1:
Sub Calculation()
Range("P2:P800").Select
Application.CutCopyMode = False
Selection.ClearContents
Dim dict1 As Object
Dim c1 As Variant, k As Variant
Dim currWS As Worksheet
Dim i As Double, lastRow As Double, tot As Double
Dim number1 As Double, number2 As Double, firstRow As Double
Set dict1 = CreateObject("Scripting.Dictionary")
Set currWS = ThisWorkbook.Sheets("Trade data")
'get last row withh data in Column A
lastRow = currWS.Cells(Rows.Count, "M").End(xlUp).Row
'put unique numbers in Column A in dict1
c1 = Range("M2:V" & lastRow)
For i = 1 To UBound(c1, 1)
If c1(i, 1) <> "" Then
'make combination with first 4 characters
dict1(Left(c1(i, 1), 4) & "," & Left(c1(i, 8), 4) & "," & Left(c1(i,
6), 10) & "," & Left(c1(i, 10), 7)) = 1
End If
Next i
'loop through all the numbers in column A
For Each k In dict1.keys
number1 = Split(k, ",")(0)
number2 = Split(k, ",")(1)
tot = 0
firstRow = 0
For i = 2 To lastRow
If k = Left(currWS.Range("M" & i).Value, 4) & "," &
Left(currWS.Range("T" & i).Value, 4) & "," & currWS.Range("R" &
i).Value & "," & (currWS.Range("O" & i).Value) Then
If firstRow = 0 Then
firstRow = i
End If
tot = tot + currWS.Range("W" & i).Value
End If
Next i
currWS.Range("P" & firstRow) = tot
Next k
Call Consolidate
Call SingleTradeMove
End Sub
Module 2 code:
Sub SingleTradeMove()
Dim wsTD As Worksheet
Set wsTD = Worksheets("Trade data")
Sheets("UnMatching").Range("A2:AK600").ClearContents
With wsTD
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To lastRow
If Left(.Cells(i, "M"), 4) <> Left(.Cells(i, "T"), 4) _
Or .Cells(i, "O") <> .Cells(i, "V") _
Or .Cells(i, "R") <> .Cells(i, "Y") Then
.Cells(i, "J").EntireRow.Copy _
Destination:=Sheets("UnMatching").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next i
End With
End Sub
Building off ian0411's answer since I can not comment yet. You can also change this name to short hand. I always change mine to CN and then an abbreviation or something short enough its not a hassle to type out. In the example the sheet name in excel is BlueMoon. So I used CNBM in VBA. This gives a reference to the sheet, and the sheet name on excel's side can be changed without effecting your code. To change the name, click the sheet you want to name in the properties box. Then below that alter the (Name) option.
Say you have a sheet named "Work data" and you programmed as Sheets("Work data"). To make this dynamic, you can use the name before the parenthese that when you launch your Visual Basic editor.
For example, you have this code:
Sheets("Work data").Select
Now you can change to this:
Sheet1.Select
And this way, no matter how users changed the sheet name, it will always work. BUT please remember, the Sheet1 can be also changed but that can only be done inside Visual Basic editor properties. You can password protected the VBA so no one can accidentally alter it.

Concatenating and iterating through multiple Cells VBA excel

I want to iterate through data (simular to that shown below) that is stored in different cells and combine them into a single cell seperated by a new line (chr(10)). The amount of data that needs to be imported into one cell will change.
2991
19391
423
435
436
The code needs to iterate through the whole sheet regardless of any line breaks. The required format is:
2991 - all three cells would be combined into one cell in the next column to this one.
19391
423
-Line space, this will need to be taken into account and is the seperator of data.
26991 - all four cells would be combined into one cell in the next column to this one.
19331
424
6764
Below is what I have got so far, it takes the column to the left of the current row and combines it, which is wrong.
Sub ConcatColumns()
Do While ActiveCell <> "" 'Loops until the active cell is blank.
ActiveCell.Offset(0, 1).FormulaR1C1 = _
ActiveCell.Offset(0, -1) & chr(10) & ActiveCell.Offset(0, 0)
ActiveCell.Offset(1, 0).Select
Loop
End Sub
You can achieve the above with this code
Sub Main()
Dim i As Long
Dim c As Range
For i = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
Dim strBuilder As String
Set c = Range("A" & i)
If Not IsEmpty(c) And i <> 1 Then
strBuilder = c & Chr(10) & strBuilder
ElseIf i = 1 Then
strBuilder = c & Chr(10) & strBuilder
c.Offset(0, 1) = Left(strBuilder, Len(strBuilder) - 1)
strBuilder = vbNullString
Else
c.Offset(1, 1) = Left(strBuilder, Len(strBuilder) - 1)
strBuilder = vbNullString
End If
Next i
End Sub
I think this could be done using a UDF.
Something like
Public Function JoinValues(rng As Range) As String
Dim cell As Range
Dim str As String
For Each cell In rng
If cell.Value <> "" Then
str = str & cell.Value & Chr(10)
End If
Next cell
If Len(str) > 1 Then JoinValues = Left(str, Len(str) - 1)
End Function
Then usage would be =JoinValues(A1:A10) in a cell to join values. You would also have to change cell formatting in the target cell to allow wrapping text for this to work properly.
Assuming your values start in cell A2 enter
=IF(A1="",joinvalues(OFFSET(A2,0,0,MATCH(TRUE,INDEX(ISBLANK(A2:A10000),0,0),0)-1)),"")
in B2 and drag the function down.

Copy Non Blank Cells From Range to Range

I wonder if you can help me with this:
Ranges B11:B251 & C11:C251 may or may not have some values.
I want to be able to copy non blank cells from cell ranges M11:M251 & N11:N251 to B11:B251 & C11:C251, so if there are any values in M&N ranges they should overwrite values in the same rows in B&C but if there are blank values in M&N ranges they should not be copied and leave the values already present (or not) in B&C.
Was I clear? ;-)
Thanks for any replies!
Sub Main()
Dim i As Long
For i = 11 To 251
If Not IsEmpty(Range("M" & i)) Then _
Range("B" & i) = Range("M" & i)
If Not IsEmpty(Range("N" & i)) Then _
Range("C" & i) = Range("N" & i)
Next i
End Sub
this code will only copy non empty values from M&N columns to B&C
This piece of code should do the trick:
Sub CopyRangeToRange()
Dim CpyFrom As Range
Dim Cell As Range
Set CpyFrom = ActiveSheet.Range("M11:N251")
For Each Cell In CpyFrom
If Cell.Value <> vbNullString Then
Cell.Offset(0, -11).Value = Cell.Value
End If
Next Cell
End Sub