Creating a form to submit a csv file with content - excel

I havethe following problem:
To be able to deploy multiple devices, I have edited some VBA code I found here and there and I'm lost at the moment... Because I'm not a coder, and I don't understand exactly what the code does, I can't figure out the solution.
The problem is: when I add 1 device, the .csv file is cluttered with data:
HOSTNAMEHQ,COUNTRYCRE,HARDWARECRE,MAC,UUID,DESCRIPTION,PLATFORM
LPAB00000013293,,,28:F1:0E:30:81:C1,,STOCK,
#N/A,,,#N/A,,STOCK,
#N/A,,,#N/A,,STOCK,
#N/A,,,#N/A,,STOCK,
#N/A,,,#N/A,,STOCK,
#N/A,,,#N/A,,STOCK,
(etc)
When I add 2 or more devices, the .csv file is OK:
HOSTNAMEHQ,COUNTRYCRE,HARDWARECRE,MAC,UUID,DESCRIPTION,PLATFORM
LPAB00000013293,,,28:F1:0E:30:81:C1,,STOCK,
LPAB00000013293,,,28:F1:0E:30:81:C1,,STOCK,
The code I'm using is:
Sub Button_Click()
Call SaveWorksheetsAsCsv
End Sub
Sub SaveWorksheetsAsCsv()
On Error Resume Next
Dim i As Long
Errorknop = vbCritical + vbOKOnly
ThisWorkbook.Sheets("Export").Visible = xlSheetVisible
ThisWorkbook.Sheets("Export").Activate
Range("A1").Select
Selection.End(xlDown).Select
LaRo = ActiveCell.Row
Range("A1").Select
Range("A2").Select
Selection.End(xlDown).Select
LR = ActiveCell.Row
LC = Last(4, ActiveSheet.Cells)
LCR = LC & LR
Range("B1:" & LCR).Copy
ThisWorkbook.Sheets("Export").Visible = xlSheetHidden
ThisWorkbook.Sheets("Export_2").Visible = xlSheetVisible
ThisWorkbook.Sheets("Export_2").Activate
Range("A1").Select
Range("A1").PasteSpecial Paste:=xlPasteValues
Dim LValue As Date
LValue = Now
Dim SaveToDirectory As String
Dim CurrentWorkbook As String
Dim CurrentFormat As Long
Dim strbody As String
Dim SigString As String
Dim Signature As String
CurrentWorkbook = ThisWorkbook.FullName
CurrentFormat = ThisWorkbook.FileFormat
SaveToDirectory = "D:\Testmap\Formulieren\"
Worksheets("Export_2").SaveAs Filename:=SaveToDirectory & Day(LValue) & Month(LValue) & Year(LValue) & Hour(LValue) & Minute(LValue) & Second(LValue) & "_1IMPORT_TEMPLATE_NN_AD_SCCM_HP", FileFormat:=xlCSV
ThisWorkbook.Saved = True
Application.Quit
End Sub
Function Last(choice As Integer, rng As Range)
' 1 = last row
' 2 = last column (R1C1)
' 3 = last cell
' 4 = last column (A1)
Dim lrw As Long
Dim lcol As Integer
Select Case choice
Case 1:
On Error Resume Next
Last = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
Case 2:
On Error Resume Next
Last = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
Case 3:
On Error Resume Next
lrw = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
lcol = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
Last = Cells(lrw, lcol).Address(False, False)
If Err.Number > 0 Then
Last = rng.Cells(1).Address(False, False)
Err.Clear
End If
On Error GoTo 0
Case 4:
On Error Resume Next
Last = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
Last = R1C1converter("R1C" & Last, 1)
For i = 1 To Len(Last)
s = Mid(Last, i, 1)
If Not s Like "#" Then s1 = s1 & s
Next i
Last = s1
End Select
End Function
Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
Function R1C1converter(Address As String, Optional R1C1_output As Integer, Optional RefCell As Range) As String
'Converts input address to either A1 or R1C1 style reference relative to RefCell
'If R1C1_output is xlR1C1, then result is R1C1 style reference.
'If R1C1_output is xlA1 (or missing), then return A1 style reference.
'If RefCell is missing, then the address is relative to the active cell
'If there is an error in conversion, the function returns the input Address string
Dim x As Variant
If RefCell Is Nothing Then Set RefCell = ActiveCell
If R1C1_output = xlR1C1 Then
x = Application.ConvertFormula(Address, xlA2, xlR1C1, , RefCell) 'Convert A2 to R1C1
Else
x = Application.ConvertFormula(Address, xlR1C1, xlA2, , RefCell) 'Convert R1C1 to A2
End If
If IsError(x) Then
R1C1converter = Address
Else
'If input address is A1 reference and A1 is requested output, then Application.ConvertFormula
'surrounds the address in single quotes.
If Right(x, 1) = "'" Then
R1C1converter = Mid(x, 2, Len(x) - 2)
Else
x = Application.Substitute(x, "$", "")
R1C1converter = x
End If
End If
End Function
For a coder this might be completely logical or even a big mess, but I really hope someone can give me the solution so the script runs, get's the information for the cells, and then stops when it finds an empty cell. At that moment, write the .csv file and close.

I found the solution using a step-by-step method with F8. Finding the last row was where the error was. Now I'm using:
Cells(Rows.Count, "A").End(xlUp).Row

Related

Search entire workbook including hidden sheets, and return the sheet name of where it was found. Do not want to unhide all worksheets first

Working on creating a single location of all my notes. Need to be able to hide all sheets and search through them for a cell value.
Have not located a code that will work, or a formula. I am open to either.
The sheets are not formatted the same and the search could be anywhere on any sheet.
Try this code:
Sub SubSearch()
'Declarations.
Dim WksTarget As Worksheet
Dim StrPO As String
Dim BlnFoundResult As Boolean
'Setting.
StrPO = "A3921"
'Covering each worksheet.
For Each WksTarget In ThisWorkbook.Worksheets
'Searching for a match.
If Not WksTarget.Cells.Find(What:=StrPO, _
After:=WksTarget.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False _
) Is Nothing _
Then
'Reporting the found match.
MsgBox StrPO & " found in " & WksTarget.Name, vbOKOnly, "Found"
'Setting BlnFoundResult as true.
BlnFoundResult = True
End If
Next
'If BlnFoundResult is still false, it's reported that no match has been found.
If BlnFoundResult = False Then
MsgBox StrPO & " has not been found", vbOKOnly, "Not found"
End If
End Sub
Here you have basically the same subroutine turned into a function that you can use in a formula:
Function FunSearch(StrWhat As String) As String
'Declarations.
Dim WksTarget As Worksheet
Dim StrPO As String
Dim StrMarker As String
'Setting.
StrPO = StrWhat
StrMarker = " | "
'Covering each worksheet.
For Each WksTarget In ThisWorkbook.Worksheets
'Searching for a match.
If Not WksTarget.Cells.Find(What:=StrPO, _
After:=WksTarget.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False _
) Is Nothing _
Then
'Reporting the found match.
FunSearch = FunSearch & WksTarget.Name & StrMarker
End If
Next
'If FunSearch is still empty, it's reported that no match has been found. Otherwise the result is trimmed of the last StrMarker.
If FunSearch = "" Then
FunSearch = "No match found"
Else
FunSearch = Left(FunSearch, Len(FunSearch) - Len(StrMarker))
End If
End Function

VBA loop selection.find

I want to loop or find multiple value in another sheets. My code doesn't work even after I do..loop the code.
For i = 1 To lastrowBAU
Worksheets(fname).Range("A1:A" & lastrowsheet).Select
Do Until Cell Is Nothing
Set Cell = Selection.find(What:=ThisWorkbook.Worksheets("BAU").Range("A" & i).Value, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
MatchCase:=False)
If Not Cell Is Nothing Then
Cell.Activate
ActiveCell.Copy
ActiveCell.Insert Shift:=xlShiftDown
ActiveCell.Offset(1, 0).Select
Selection.Replace What:=ThisWorkbook.Worksheets("BAU").Range("A" & i).Value, _
replacement:=ThisWorkbook.Worksheets("BAU").Range("B" & i).Value, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
Set Cell = Worksheets(fname).Range("A1:A" & lastrowsheet).FindNext(Cell)
End If
Loop
Next i
You need to set the cell before entering the loop
Set cell = rngSrc.Find(sA, LookIn:=xlFormulas, LookAt:=xlPart, _
After:=rngSrc.Cells(rngSrc.Cells.Count), SearchOrder:=xlByRows, MatchCase:=False)
If Not cell Is Nothing Then
however you also need to avoid an endless loop by checking if the search has returned to the first one found.
Option Explicit
Sub macro1()
Dim ws As Worksheet, wsBAU As Worksheet
Dim cell As Range, rngSrc As Range
Dim fname As String, lastrow As Long, lastrowBAU As Long
Dim i As Long, n As Long, first As String
Dim sA As String, sB As String
fname = "Sheet1"
With ThisWorkbook
Set ws = .Sheets(fname)
Set wsBAU = .Sheets("BAU")
End With
With ws
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rngSrc = .Range("A1:A" & lastrow)
End With
With wsBAU
lastrowBAU = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
With ws
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rngSrc = .Range("A1:A" & lastrow)
End With
' search and replace
Application.ScreenUpdating = False
For i = 1 To lastrowBAU
sA = wsBAU.Cells(i, "A")
sB = wsBAU.Cells(i, "B")
Set cell = rngSrc.Find(sA, LookIn:=xlFormulas, LookAt:=xlPart, _
After:=rngSrc.Cells(rngSrc.Cells.Count), SearchOrder:=xlByRows, MatchCase:=False)
If Not cell Is Nothing Then
first = cell.Address
Do
' insert cell above
cell.Insert xlDown
cell.Offset(-1).Value2 = cell.Value2
cell.Value2 = Replace(cell.Value2, sA, sB)
' expand search range
n = n + 1
Set rngSrc = ws.Range("A1:A" & lastrow + n)
' find next
Set cell = rngSrc.FindNext(cell)
Loop While cell.Address <> first
End If
Next
Application.ScreenUpdating = True
MsgBox n & " replacements", vbInformation
End Sub

What is correct syntax for using R1C1 and clearing formats of a Range to end of sheet?

I am making a macro that Optimizes the sheet by deleting unused ranges that create very large file sizes. It does this by finding the last used row (column), selecting a range from that last used row (column) to the very bottom-right) of the sheet, and clearing formats and deleting those cells, to delete the unused range that is taking up space.
E.g. if last used row is 50, select range A50 to Bottom right of sheet (aka XFD104873, clear those formats and delete range
I have been able to do this with rows, but not with columns. In the below code, I get a syntax error (shown as 'SYNTAX ERROR' below) when case 2 runs, and I can't for the life of me figure out why.
I need to use R1C1 notation but for some reason the range(cells(#,#)) aren't picking it up properly.
I think it has to do with the second part in which I do range(cells(#,#)).End(xlDown).end(Toright)
Let me know if i can provide any additional information!
Nick
'Option Explicit
Sub Optimize()
'Call OptimizeSheet(1, "HR_Data")
Call OptimizeSheet(2, "DomesticAsset_Data")
'Call OptimizeSheet(3, "InternationalAsset_Data")
End Sub
Sub OptimizeSheet(ByVal choice As Long, ByVal sht As String)
' 1 = Rows
' 2 = Columns
' 3 = Both
If WorksheetExists(sht) = False Then
MsgBox "Worksheet doesn't exist, check macro code"
Exit Sub
End If
'Workbook
Dim wb As Workbook
'Last Row and Column Variables
Dim lr As Long
Dim lc As Long
'File Size variables
Dim aFileSize As Long
Dim bFileSize As Long
Dim chngFileSize As Long
Set wb = Application.ActiveWorkbook
On Error GoTo errHandler
'Get file size before optimizing
aFileSize = FileLen(Application.ActiveWorkbook.FullName)
Select Case choice
'Rows
Case 1:
lr = Worksheets(sht).Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
With Worksheets(sht).Range("A" & lr, Range("A" & lr).End(xlDown).End(xlToRight))
.ClearFormats
.Delete
End With
'Columns
Case 2:
lc = Worksheets(sht).Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
SYNTAX ERROR HERE
With Worksheets(sht).Range(Cells(1, lc), RangeCells(1, lc).End(xlDown).End(xlToRight))
.ClearFormats
.Delete
End With
'Both
Case 3:
lr = Worksheets(sht).Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
With Worksheets(sht).Range("A" & lr, Range("A" & lr).End(xlDown).End(xlToRight))
.ClearFormats
.Delete
End With
'chnge
lc = Worksheets(sht).Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
With Worksheets(sht).Range(Cells(1, lc).Address(), Range(Cells(1, lc).Address()).End(xlDown).End(xlToRight))
.ClearFormats
.Delete
End With
Case Else:
MsgBox "Wrong Choice, check macro code"
End Select
Application.ThisWorkbook.Save
bFileSize = FileLen(Application.ActiveWorkbook.FullName)
If aFileSize + bFileSize = 0 Then
MsgBox "error in filesize"
End If
chngFileSize = bFileSize - aFileSize
If chngFileSize = 0 Then
MsgBox (sht & " already optimized")
Else
MsgBox ("Done. " & (chngFileSize / 1000) & "MB Saved")
End If
Exit Sub
errHandler:
MsgBox "error on line" & Erl
End Sub
Function WorksheetExists(shtName As String, Optional wb As Workbook) As
Boolean
Dim sht As Worksheet
If wb Is Nothing Then Set wb = ThisWorkbook
On Error Resume Next
Set sht = wb.Sheets(shtName)
On Error GoTo 0
WorksheetExists = Not sht Is Nothing
End Function
To delete columns:
With Worksheets(sht)
.Range(.Cells(1, lc + 1), _
.Cells(1, lc +1 ).End(xlToRight)).EntireColumn.Delete
End With

Run VBA Excel script on an Excel document from an Access subroutine

I have a section of code to find the bottom right cell, that runs in excel, and I want to be able to run it through an Access subroutine, which will return the cell coordinates (Ex.: J17). However I'm not that familiar with Access and am unsure of how to translate the code.
Sub FindLast_Message()
MsgBox FindLast(3)
End Sub
Function FindLast(lRowColCell As Long, _
Optional sSheet As String, _
Optional sRange As String)
'Find the last row, column, or cell using the Range.Find method
'lRowColCell: 1=Row, 2=Col, 3=Cell
Dim lRow As Long
Dim lCol As Long
Dim wsFind As Worksheet
Dim rFind As Range
'Default to ActiveSheet if none specified
On Error GoTo ErrExit
If sSheet = "" Then
Set wsFind = ActiveSheet
Else
Set wsFind = Worksheets(sSheet)
End If
'Default to all cells if range no specified
If sRange = "" Then
Set rFind = wsFind.Cells
Else
Set rFind = wsFind.Range(sRange)
End If
On Error GoTo 0
Select Case lRowColCell
Case 1 'Find last row
On Error Resume Next
FindLast = rFind.Find(What:="*", _
After:=rFind.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
Case 2 'Find last column
On Error Resume Next
FindLast = rFind.Find(What:="*", _
After:=rFind.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
Case 3 'Find last cell by finding last row & col
On Error Resume Next
lRow = rFind.Find(What:="*", _
After:=rFind.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
On Error Resume Next
lCol = rFind.Find(What:="*", _
After:=rFind.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
On Error Resume Next
FindLast = wsFind.Cells(lRow, lCol).Address(False, False)
'If lRow or lCol = 0 then entire sheet is blank, return "A1"
If Err.Number > 0 Then
FindLast = rFind.Cells(1).Address(False, False)
Err.Clear
End If
On Error GoTo 0
End Select
Exit Function
ErrExit:
MsgBox "Error setting the worksheet or range."
End Function
Below is the section of Access code where I need to coordinate this with. The 'J72' should be the bottom right cell coordinate as returned by the previous code.
Sub Format_Excel_Workbook(workbook_path As String, worksheet_name As String, myRows As Integer, myColumns As Integer)
'==============================================================================
Dim objExcelApp As Object
Dim xlWbk As Object
'==============================================================================
Dim x, y As String
x = "B2"
y = "J72"
Z = x & ":" & y
'==============================================================================
Set objExcelApp = New Excel.Application
objExcelApp.Workbooks.Open (workbook_path)
objExcelApp.Worksheets("t_DATA").Columns.AutoFit
objExcelApp.Worksheets("t_DATA").Range(x).Select
objExcelApp.ActiveWindow.FreezePanes = True
objExcelApp.Worksheets("t_DATA").Range(Z).HorizontalAlignment = xlCenter
objExcelApp.Worksheets("t_DATA").Range(Z).VerticalAlignment = xlTop
objExcelApp.ActiveWorkbook.Close (True)
Set objExcelApp = Nothing
'==============================================================================
End Sub
The easiest way is probably to change the parameters of your FindLast() function to objects instead of strings:
Function FindLast(lRowColCell As Long, _
Optional sSheet As Excel.Worksheet, _
Optional sRange As Excel.Range)
From Excel, you could call this function like this:
FindLast(3, , FindLast(3, , ThisWorkbook.Sheets(1).Range("A3:E7")))
In the function you have to change those parts where the parameters sSheet and sRange are used: Simply use the provided objects instead of creating them from the strings.
With the function changed this way you can easily transport it to other host applications like Access, because the caller of the function defines the objects on which the function should operate, not the function itself.
From Access you could invoke the function like this:
FindLast(3, , objExcelApp.Worksheets("t_DATA").Range(Z))

how to replace word lookAt:=xlWhole including japanese comma in excel macro

have to replace the word in excel cell .
using like
Sub test()
Dim a_row As String
Dim b_row As String
Dim row_counter As Integer
For row_counter = 1 To 600
a_row = "A" & row_counter
b_row = "B" & row_counter
Dim Findtext As String
Dim Replacetext As String
Findtext = Sheets("sheet1").Range(a_row).Value
Replacetext = Sheets("sheet1").Range(b_row).Value
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> ActiveWorkbook.Worksheets(1).Name Then
ws.Cells.Replace What:=Findtext, Replacement:=Replacetext, LookAt:= _
xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
End If
Next ws
Next row_counter
End Sub
there are two cols in sheet1. 1st cols shows Japanese words. 2nd column shows English words.
公園 park
夏 summer
緑 Green
青空 blue Sky
男の人 man
In the 2nd sheet displays in col A
column A
公園、夏、青空、緑、男の人
the above code replace Japanese words.
if LookAt:= _xlPart, after replace shows like below
park, summer, 青sky, green,manの人
if LookAt:= _xlWhole , its not replacing the word
In the 2nd sheet displays in the separate columns
A B C D E
公園 夏 青空 緑 男の人
if LookAt:= _xlWhole then
its working perfectly.
i want to do
In the 2nd sheet displays the value in single col A delimited by comma
column A
公園、夏、青空、緑、男の人
need the output like
park, summer, blue sky, green,man
please give some idea.. thanks
Do it in memory instead, it's quicker and much easier to work with arrays. If I understand the way your data is set out - the following should work where your find/replace table is in columns A:B on sheet1 and the values to replace are in sheet2 and are comma separated in cell A1:
Sub MM_Foo()
Dim findArray As Variant
Dim replaceArray As Variant
Dim matchPosition As Long
With Sheets(1)
findArray = .Range("A1:B" & .Cells(.Rows.Count, 2).End(xlUp).Row).Value
End With
On Error GoTo checkErr:
For j = 1 To Sheets(2).Cells(Sheets(2).Rows.Count, 1).End(xlUp).Row
replaceArray = Split(Sheets(2).Cells(j, 1).Value, ",")
With Application
For i = LBound(replaceArray) To UBound(replaceArray)
matchPosition = .Match(replaceArray(i), .Index(findArray, , 1), 0)
replaceArray(i) = findArray(matchPosition, 2)
skipReplace:
Next
End With
Sheets(2).Cells(j, 1).Value = Join$(replaceArray, ",")
Next
On Error GoTo 0
Exit Sub
checkErr:
If Err.Number = 13 Then
Err.Clear
GoTo skipReplace:
Else
MsgBox Err.Description & " (" & Err.Number & ")", vbExclamation, "Error"
Err.Clear
On Error GoTo 0
Exit Sub
End If
End Sub
Without a trailing 'comma', there may have to be repetitive passes that may or may not actually do anything; there need to cover all possible combinations.
Sub delimitedTranslate()
Dim w As Long, vWRDs As Variant
With Worksheets("Sheet1")
vWRDs = .Range(.Cells(2, "A"), _
.Cells(Rows.Count, "A").End(xlUp).Offset(0, 1)) _
.Value2
End With
With Worksheets("Sheet2")
With .Columns("A")
For w = LBound(vWRDs, 1) To UBound(vWRDs, 1)
.Replace what:=vWRDs(w, 1) & ChrW(12289), _
replacement:=vWRDs(w, 2) & Chr(44), _
lookat:=xlPart, MatchCase:=False, searchformat:=False
.Replace what:=ChrW(12289) & vWRDs(w, 1), _
replacement:=Chr(44) & vWRDs(w, 2), _
lookat:=xlPart, MatchCase:=False, searchformat:=False
.Replace what:=Chr(44) & vWRDs(w, 1), _
replacement:=Chr(44) & vWRDs(w, 2), _
lookat:=xlPart, MatchCase:=False, searchformat:=False
Next w
End With
End With
End Sub
                   Sheet1 terms                  Sheet2 before delimitedTranslate                 Sheet2 after delimitedTranslate

Resources