I am trying to improve below VBA I found in this thread. Would it be possible to have this code in the form of Application.Dialogs(xlDialogSaveAs).Show(Arg2:=xlCSV) method, so I can choose where to save the CSV file?
Option Explicit
Sub CSV_Makerr()
Dim r As Range
Dim sOut As String, k As Long, M As Long
Dim N As Long, nFirstRow As Long, nLastRow As Long
Dim MyFilePath As String, MyFileName As String
Dim fs, a, mm As Long
Dim separator As String
ActiveSheet.UsedRange
Set r = ActiveSheet.UsedRange
nLastRow = r.Rows.Count + r.Row - 1
nFirstRow = r.Row
separator = ","
MyFilePath = "C:\TestFolder\"
MyFileName = "whatever"
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile(MyFilePath & MyFileName & ".csv", True)
For N = nFirstRow To nLastRow
k = Application.WorksheetFunction.CountA(Cells(N, 1).EntireRow)
sOut = ""
If k = 0 Then
Else
M = Cells(N, Columns.Count).End(xlToLeft).Column
For mm = 1 To M
sOut = sOut & Cells(N, mm).Text & separator
Next mm
sOut = Left(sOut, Len(sOut) - 1)
a.writeline (sOut)
End If
Next
a.Close
End Sub
The idea is to remove the commas from the CSV or blank column that is persistently exist even after I delete it several times. Above code works, but without the liberty to choose the location path for different end users or PC. Kindly let me know if it's possible.
Something like this?
Sub CSV_Makerr()
Dim r As Range
Dim sOut As String, k As Long, M As Long
Dim N As Long, nFirstRow As Long, nLastRow As Long
Dim MyFilePath As String, MyFileName As String
Dim fs, a, mm As Long
Dim separator As String
ActiveSheet.UsedRange
Set r = ActiveSheet.UsedRange
nLastRow = r.Rows.Count + r.Row - 1
nFirstRow = r.Row
separator = ","
MyFilePath = Application.GetSaveAsFilename(fileFilter:="CSV Files (*.csv), *.csv")
If MyFilePath <> "" Then
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile(MyFilePath, True)
For N = nFirstRow To nLastRow
k = Application.WorksheetFunction.CountA(Cells(N, 1).EntireRow)
sOut = ""
If k = 0 Then
Else
M = Cells(N, Columns.Count).End(xlToLeft).Column
For mm = 1 To M
sOut = sOut & Cells(N, mm).Text & separator
Next mm
sOut = Left(sOut, Len(sOut) - 1)
a.writeline (sOut)
End If
Next
a.Close
End If
End Sub
Related
Sub ExportDataTSV()
Dim BCS As Worksheet
Dim Ctrl As Worksheet
Dim ws As Worksheet
Dim FName As String
Dim insertValues As String
Application.ScreenUpdating = False
Set BCS = ThisWorkbook.Sheets(Sheet2.Name)
Set Ctrl = ThisWorkbook.Sheets(Sheet1.Name)
#If Mac Then
NameFolder = "documents folder"
If Int(Val(Application.Version)) > 14 Then
'You run Mac Excel 2016
folder = _
MacScript("return POSIX path of (path to " & NameFolder & ") as string")
'Replace line needed for the special folders Home and documents
folder = _
Replace(SpecialFolder, "/Library/Containers/com.microsoft.Excel/Data", "")
Else
'You run Mac Excel 2011
folder = MacScript("return (path to " & NameFolder & ") as string")
End If
FName = folder & "bcs_output.tsv"
#Else
folder = Environ$("userprofile")
Debug.Print folder
FName = folder & "Documents\bcs_output.tsv"
#End If
If Ctrl.Range("D9") = "" Or Ctrl.Range("D10") = "" Then
MsgBox "Please enter the Scenario Year and Scenario you wish to save and click again", vbOKOnly
Exit Sub
End If
Ctrl.Range("D9").Copy
BCS.Range("AS2").PasteSpecial Paste:=xlPasteValues
Ctrl.Range("D10").Copy
BCS.Range("AT2").PasteSpecial Paste:=xlPasteValues
With BCS
numrows = .Cells(.Rows.Count, 1).End(xlUp).Row
numcol = .Cells(2, Columns.Count).End(xlToLeft).Column
.Range("AS1").Value = "scenario_year"
.Range("AS2:AS" & numrows).FillDown
.Range("AT1").Value = "scenario"
.Range("AT2:AT" & numrows).FillDown
.Range("AU1").Value = "save_date"
.Range("AU2").Formula = "=NOW()"
.Range("AU2:AU" & numrows).FillDown
.Range("AU2:AU" & numrows).NumberFormat = "yyyy-mm-dd hh:mm"
For x = 2 To numrows
Set rng1 = .Range("A" & x & ":R" & x)
Set rng2 = .Range("AC" & x & ":AF" & x)
Set rng3 = .Range("AH" & x & ":AK" & x)
Set rng4 = .Range("AN" & x & ":AO" & x)
Set rng5 = .Range("AS" & x & ":AU" & x)
Set Data = Union(rng1, rng2, rng3, rng4, rng5)
insertValues = Join2D(ToArray(Data), Chr(9))
Debug.Print insertValues
Call ConvertText(FName, insertValues)
Next x
End With
With BCS
.Activate
.Range("A1").Select
End With
Ctrl.Activate
Application.ScreenUpdating = True
MsgBox "Cluster Data saved to your documents folder, please upload the file here: ", vbOKOnly
End Sub
Function ToArray(rng) As Variant()
Dim arr() As Variant, r As Long, nr As Long
Dim ar As Range, c As Range, cnum As Long, rnum As Long
Dim col As Range
nr = rng.Areas(1).Rows.Count
ReDim arr(1 To nr, 1 To rng.Cells.Count / nr)
cnum = 0
For Each ar In rng.Areas
For Each col In ar.Columns
cnum = cnum + 1
rnum = 1
For Each c In col.Cells
arr(rnum, cnum) = c.Value
rnum = rnum + 1
Next c
Next col
Next ar
ToArray = arr
End Function
Public Function Join2D(ByVal vArray As Variant, Optional ByVal sWordDelim As String = " ", Optional ByVal sLineDelim As String = vbNewLine) As String
Dim i As Long, j As Long
Dim aReturn() As String
Dim aLine() As String
ReDim aReturn(LBound(vArray, 1) To UBound(vArray, 1))
ReDim aLine(LBound(vArray, 2) To UBound(vArray, 2))
For i = LBound(vArray, 1) To UBound(vArray, 1)
For j = LBound(vArray, 2) To UBound(vArray, 2)
'Put the current line into a 1d array
aLine(j) = vArray(i, j)
Next j
'Join the current line into a 1d array
aReturn(i) = Join(aLine, sWordDelim)
Next i
Join2D = Join(aReturn, sLineDelim)
End Function
Function ConvertText(myfile As String, strTxt As String)
Dim objStream
Set objStream = CreateObject("ADODB.Stream")
With objStream
'.Charset = "utf-8"
.Open
.WriteText strTxt
.SaveToFile myfile, 2
'.Close
End With
'Set objStream = Nothing
End Function
I attempted the above to write the non-contiguous ranges to a tab delimited file. I get a 3004 error - Unable to write file from that code. I am not sure why it can't write the file and since I can't even write the file I can't tell if it will write each row of data until there are no more. Can anyone assist with at least helping me get the file to write?
You need to separate folder and "Documents\bcs_output.tsv" with a backslash. In MacOS I believe the path separator is ":" (colon), not "\" (backslash).
SO I have a list of words ( they are 250ish medications in my Settings sheet ) , and I want to use vba to find those specific words in Column D of another sheet and color them magenta. Column D has 105 cells that are full of text.
text I want to search:
list of meds:
what I want it to look like:
below is what iv gathered from other resources but I just cant get it to work! please let me know if you have any suggestions!
also it kinda has to work with mac and windows excel
Sub ColorWords3()
Dim Position As Long, Cell As Range, W As Variant, Words As Variant, Txt As String, druglastcol As Variant, drugs As Variant
druglastcol = Sheets("Settings").Range("A" & Rows.Count).End(xlUp).Row
'Words = Array("TEXT", "WORD", "THEN")
Words = Application.Transpose(Sheets("Settings").Range("A4:A" & druglastcol).Text)
For Each Cell In Columns("D").SpecialCells(xlConstants)
Txt = " " & UCase(Cell.Value) & " "
For Each W In Words
Position = InStr(Txt, W)
Do While Position > 0
If Mid(Txt, Position - 1, Len(W) + 2) Like "[!A-Z0-9]" & W & "[!A-Z0-9]" Then
With Cell.Characters(Position - 1, Len(W)).Font
.Bold = True
.Color = vbRed
End With
End If
Position = InStr(Position + 1, Txt, W)
Loop
Next
Next
End Sub
Like is case-sensitive, so you need to upper-case your drug names to match your upper-cased blocks of text.
If Mid(Txt, Position - 1, Len(W) + 2) Like "[!A-Z0-9]" & UCase(W) & "[!A-Z0-9]" Then
Using Like gets a bit clunky so here's a RegExp-based approach:
EDIT - added a working Like/InStr version...
Sub ColorWords()
Dim Cell As Range, W, Words, matches As Collection, m
With Sheets("Settings")
Words = Application.Transpose(.Range(.Range("A4"), _
.Cells(.Rows.Count, 1).End(xlUp)))
End With
For Each Cell In ActiveSheet.Columns("D").SpecialCells(xlConstants)
For Each W In Words
'Set matches = AllMatchesRegEx(Cell.Text, W) 'windows only
Set matches = AllMatchesInStr(Cell.Text, W) 'windows+mac
For Each m In matches
Debug.Print Cell.Address, W, m
With Cell.Characters(m, Len(W)).Font
.Bold = True
.Color = vbMagenta
End With
Next m
Next
Next
End Sub
Function AllMatchesInStr(ByVal textToSearch As String, searchTerm)
Const OUT As String = "[!A-Z0-9]"
Dim rv As New Collection, pos As Long, start As Long
Dim next2 As String, next1 As String
textToSearch = UCase(" " & textToSearch & " ")
start = 1
pos = InStr(start, textToSearch, searchTerm, vbTextCompare)
Do While pos > 0
If Mid(textToSearch, pos - 1, 1) Like OUT Then
next2 = Mid(textToSearch, pos + Len(searchTerm), 2)
next1 = Left(next2, 1)
'Handle possible s at end of search term
If next1 Like OUT Or (next2 Like "S" & OUT) Then
rv.Add pos - 1
End If
End If
start = pos + 1
pos = InStr(start, textToSearch, searchTerm, vbTextCompare)
Loop
Set AllMatchesInStr = rv
End Function
Function AllMatchesRegEx(textToSearch As String, searchTerm)
Dim rv As New Collection, matches, m
Static reg As Object
If reg Is Nothing Then
Set reg = CreateObject("VBScript.RegExp")
reg.Global = True
reg.IgnoreCase = True
End If
reg.Pattern = "\b" & searchTerm & "s?\b" 'Allow for simple plural form,
'flank with word boundaries
Set matches = reg.Execute(textToSearch)
For Each m In matches
rv.Add m.firstindex + 1 'firstindex is zero-based
Next m
Set AllMatchesRegEx = rv
End Function
There is a mistake in your code:
Words = Application.Transpose(Sheets("Settings").Range("A4:A" & Dr).Text)
what is Dr?
Also don't do this:
druglastcol = Sheets("Settings").Range("A4:A" & Rows.Count).End(xlDown).Row
Do this instead:
druglastcol = Sheets("Settings").Range("A" & Rows.Count).End(xlUp).Row
The reason we do it this way is the method you have used will stop if there is a blank row in the data, the method i have posted comes from the bottom up so will always grab the true last row.
Try
Sub test()
Dim Ws As Worksheet
Dim s As String
Dim vDB
Dim i As Long
'Application.ScreenUpdating = False
Set Ws = Sheets("Settings")
With Ws
vDB = .Range("a1", .Range("a" & Rows.Count).End(xlUp))
End With
For i = 1 To UBound(vDB, 1)
s = vDB(i, 1)
setCharacterColor s
Next i
'Application.ScreenUpdating = True
End Sub
Sub setCharacterColor(strPattern As String)
Dim mCol As Object 'MatchCollection
Dim Ws As Worksheet
Dim rngDB As Range, rng As Range
Dim s As String
Dim i As Integer, Ln As Integer
Set Ws = Sheets("Facts")
Set rngDB = Ws.Range("d1", Ws.Range("d" & Rows.Count).End(xlUp))
For Each rng In rngDB
s = rng.Value
Set mCol = GetRegEx(s, strPattern)
If Not mCol Is Nothing Then
For i = 0 To mCol.Count - 1
c = mCol.Item(i).FirstIndex + 1
Ln = mCol.Item(i).Length
With rng.Characters(c, Ln).Font
.Bold = True
.Color = vbMagenta
End With
Next i
End If
Next
End Sub
Function GetRegEx(StrInput As String, strPattern As String) As Object
Dim RegEx As Object 'New RegExp
Set RegEx = CreateObject("VBScript.RegExp") 'New RegExp
With RegEx
.Global = True
.IgnoreCase = False
.MultiLine = True
.Pattern = strPattern
End With
If RegEx.test(StrInput) Then
Set GetRegEx = RegEx.Execute(StrInput)
End If
End Function
If your use Mac then try below.
Sub test()
Dim Ws As Worksheet, WsColor As Worksheet
Dim rngDB As Range, rng As Range
Dim s As String
Dim vDB, vR
Dim i As Long, Ln As Integer
Dim j As Index
Dim st, et
Application.ScreenUpdating = False
st = Timer
Set Ws = Sheets("Settings")
Set WsColor = Sheets("Facts")
With Ws
vDB = .Range("a1", .Range("a" & Rows.Count).End(xlUp))
End With
With WsColor
Set rngDB = .Range("d1", .Range("d" & Rows.Count).End(xlUp))
End With
For Each rng In rngDB
For i = 1 To UBound(vDB, 1)
Ln = Len(vDB(i, 1)) 'String Length
vR = getItem(rng, vDB(i, 1)) 'string startedIndex
If IsArray(vR) And Not IsEmpty(vR) Then
For j = 1 To UBound(vR)
With rng.Characters(vR(j), Ln).Font
.Bold = True
.Color = vbMagenta
End With
Next j
End If
Next i
Next rng
Application.ScreenUpdating = True
et = Timer
Debug.Print et - st
End Sub
Function getItem(rng As Range, v As Variant) As Variant
Dim vR()
Dim k As Integer, s As Integer, n As Index
Dim str As String
str = rng.Text
s = 1
Do
n = InStr(s, str, v)
If n > 0 Then
k = k + 1
ReDim Preserve vR(1 To k)
vR(k) = n
End If
s = n + Len(v)
DoEvents
Loop While n > 0
If k Then
getItem = vR
Else
getItem = Empty
End If
End Function
When I have a workbook with VBA code that includes a custom function, the debugger randomly steps into the function mid-code.
This happens both when I have UDF in .xlam files, and custom functions in local macros. It wouldn't be an issue if it only loops through the function once but it seems to loop infinitely, which makes debugging impossible.
e.g. here is one which gave me the issue today:
Sub checkdailytotal()
Dim i As Long, j As Long, k As Long, m As Long, n As Long
Dim filepath As String, filedate As String, filename As String, filename2 As String, _
filename3 As String, filetoopen As String
Dim totalunit As Double
Dim checkcount As Range
Dim wb As Workbook
Dim ws As Worksheet
Dim rg As Range, rg2 As Range, reg As Range, unitcol As Range, daterow As Range
Dim regcheck As Range, regfind As Range
Dim regnum As String, nofile As String, nofind As String, nomatch As String, _
totalmatch As String
Dim sharec As Double, sharediff As Double, totalshare As Double
Dim check As Range
Application.DisplayAlerts = False
Application.ScreenUpdating = False
filepath = "C:\Username\filepath\"
On Error Resume Next
With Sheet3
Set checkcount = .Range("B2")
.Range("A3:E50").Clear 'This is where the function got called
End With
With Sheet2
i = WorksheetFunction.Count(.Range("A:A"))
Set reg = .Range("A2", .Cells(2, .Range("A2").End(xlToRight).Column))
Set unitcol = .Range("C2", .Cells(.Range("C2").End(xlDown).Row, "C"))
For j = 1 To i 'change this to i, just testing
Set daterow = .Range("A2").Offset(j, 0)
checkcount.Offset(j, -1).Value = j
filedate = Format(.Range("A2").Offset(j, 0).Value, "YYYYMMDD")
filename = filepath & "XYZ File name" & filedate & ".xlsx"
filename2 = filepath & "XYZ file name" & _
Format(.Range("A2").Offset(j, 0).Value, "DD.MM.YYYY") & ".xlsx"
filename3 = filepath & filedate & ".xlsx"
If Len(Dir(filename)) = 0 Then
If Len(Dir(filename2)) = 0 Then
If Len(Dir(filename3)) = 0 Then
nofile = "No File"
Else
filetoopen = filename3
End If
Else
filetoopen = filename2
End If
Else
filetoopen = filename
End If
Set wb = Workbooks.Open(filetoopen, Password:="password")
Set ws = wb.Worksheets(1)
With ws
nofind = ""
nomatch = ""
Set regcheck = .Range("H2")
n = .Range("A2").End(xlDown).Row - 2
For k = 1 To n
regnum = regcheck.Offset(k, 0).Value
Set regfind = reg.Find(regnum, LookIn:=xlValues, lookat:=xlWhole)
If regfind Is Nothing Then
nofind = nofind & " " & regfind
Else
'find the sharecount in monthly file
sharec = regfind.Offset(j, 0).Value
sharediff = regcheck.Offset(k, 4).Value - sharec
If Abs(Round(sharediff, 1)) > 0 Then
nomatch = nomatch & " " & regfind & " " & sharediff
End If
End If
Next k
wb.Close False
totalshare = regcheck.Offset(j + 1, 4).Value
totalmatch = Abs(Round(totalshare - unitcol.Value, 1))
Call totalcheck(daterow.Value, nofile, totalmatch, nofind, nomatch)
nofile = ""
End With
Next j
End With
MsgBox "Check complete"
Application.Goto Sheet3.Range("A1")
End Sub
Sub totalcheck(datech As Double, nofilepath As String, totalshare As String, _
regfind As String, regmatch As String)
Dim check As Range
Dim m As Long
With Sheet3
Set check = .Range("B2")
m = WorksheetFunction.Count(.Range("A:A"))
Set check = check.Offset(m, 0)
With check
With .Offset(0, 0)
.Value = datech
.NumberFormat = "m/d/yyyy"
End With
.Offset(0, 1).Value = nofilepath
.Offset(0, 2).Value = totalshare
.Offset(0, 3).Value = regfind
.Offset(0, 4).Value = regmatch
End With
End With
End Sub
Function tplus1(todaydt As Date)
Dim holidays As Range
Dim wk As Long, wk2 As Long, wk3 As Long, i As Long, j As Long
Dim t1 As Date
wk = WorksheetFunction.Weekday(todaydt, 2) 'mon=1, sun=7
If wk > 5 Then
tplus1 = "Weekend"
Exit Function
End If
If wk < 5 Then 'mon-thurs
t1 = todaydt + 1
Else 'friday
t1 = todaydt + 3
End If
With Sheet4
Set holidays = .Range("A2", .Cells(.Range("A2").End(xlDown).Row, "A"))
End With
i = WorksheetFunction.CountIf(holidays, t1)
wk2 = WorksheetFunction.Weekday(t1, 2) 'mon=1, sun=7
If i = 0 Then
tplus1 = t1
Exit Function
End If
If i > 0 Then
Do Until i = 0
If wk2 < 5 Then
t1 = t1 + 1
i = WorksheetFunction.CountIf(holidays, t1)
ElseIf wk2 = 5 Then
t1 = t1 + 3
i = WorksheetFunction.CountIf(holidays, t1)
ElseIf wk2 = 6 Then
t1 = t1 + 2
i = WorksheetFunction.CountIf(holidays, t1)
ElseIf wk2 = 7 Then
t1 = t1 + 1
i = WorksheetFunction.CountIf(holidays, t1)
End If
wk2 = WorksheetFunction.Weekday(t1, 2)
Loop
End If
tplus1 = t1
End Function
My rows do not have the same length and I need to avoid the "blanks" in between when I export to CSV.
For example, when I export this:
1 2 3 4 5
1 2
1 3 3 4
1 2 3 4 5
I get this:
1,2,3,4,5
1,2,,,
1,3,3,4,
1,2,3,4,5
And I need to remove the extra seperators from the empty cells between.
I am already running a macro to export as CSV, so it would be best if I could "delete" the empty cells in the beginning of this.
This small macro will:
avoid creating empty CSV records corresponding to empty Excel rows
avoid trailing commas
Option Explicit
Sub CSV_Makerr()
Dim r As Range
Dim sOut As String, k As Long, M As Long
Dim N As Long, nFirstRow As Long, nLastRow As Long
Dim MyFilePath As String, MyFileName As String
Dim fs, a, mm As Long
Dim separator As String
ActiveSheet.UsedRange
Set r = ActiveSheet.UsedRange
nLastRow = r.Rows.Count + r.Row - 1
nFirstRow = r.Row
separator = ","
MyFilePath = "C:\TestFolder\"
MyFileName = "whatever"
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile(MyFilePath & MyFileName & ".csv", True)
For N = nFirstRow To nLastRow
k = Application.WorksheetFunction.CountA(Cells(N, 1).EntireRow)
sOut = ""
If k = 0 Then
Else
M = Cells(N, Columns.Count).End(xlToLeft).Column
For mm = 1 To M
sOut = sOut & Cells(N, mm).Text & separator
Next mm
sOut = Left(sOut, Len(sOut) - 1)
a.writeline (sOut)
End If
Next
a.Close
End Sub
I found it was pretty simple to solve, I just added a loop to check and delete if the last symbol in a line was a seperator
With Selection
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With
Else
With ActiveSheet.UsedRange
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With
End If
For RowNdx = StartRow To EndRow
WholeLine = ""
For ColNdx = StartCol To EndCol
If Cells(RowNdx, ColNdx).Value = "" Then
CellValue = ""
Else
CellValue = Cells(RowNdx, ColNdx).Value
End If
WholeLine = WholeLine & CellValue & Sep
Next ColNdx
WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
//I added this to delete the last seperator in a line before printing
Dim last As String
last = Right(WholeLine, 1)
Do Until last <> ","
WholeLine = Left(WholeLine, Len(WholeLine) - 1)
last = Right(WholeLine, 1)
Loop
Print #nFileNum, WholeLine
Next RowNdx
I need to a dynamic way to concatinate some cells in a row with a delimiter (in this instance |) as the columns move about (per project) this has to be by header names (there might be from 2 to many) columns that need to be concatinated for a project
I am trying to use arrays as there can be as many as 4000,000 rows
I have been trying for hours and here is my effort I know it is very wrong but I am at a loss
Thank you
Sub CAT()
fCAT "ElementsFile", "ElementsFile", "D", Array("Age", "Gender Identity", "Ethnicity1", "Ethnicity1")
End Sub
Sub fCAT(sShtName As String, pbShtName As String, InsertCol As String, ar As Variant)
Dim myresult
Dim col1 As String, col2 As String, col3 As String, col4 As String
Dim aLR As Long, i As Long, j As Long, k As Long
'Totaly at a loss here
For i = LBound(ar) To UBound(ar)
Dim ari As Variant
Dim coli As String
Next i
Set wsS = ThisWorkbook.Sheets(sShtName)
Set wsPB = ThisWorkbook.Sheets(pbShtName)
With wsS
aLR = .Range("A" & .Rows.Count).End(xlUp).Row
For i = LBound(ar) To UBound(ar)
j = .Rows(1).Find(ar(i)).Column
ari = .Range(Cells(1, j), Cells(aLR, j)).Select
Next i
End With
'Totaly at a loss here
ReDim myresult(1 To aLR, 1 To aLR)
For k = 1 To aLR
For i = LBound(ar) To UBound(ar)
j = wsS.Rows(1).Find(ar(i)).Column
myresult(k, 1) = Cells(k, j) & "|" & Cells(k, j + 1) & "|" & Cells(k, j + 2) & "|" & Cells(k, j + 3)
Next i
Next k
wsT.Range("D1").Resize(aLR, 1) = myresult
End Sub
Here is what I finally came up with a bit of a mess maybe but it works
Sub concat()
Dim myresult, CN
Dim HN As Variant
Dim wsS As Worksheet, wsPB As Worksheet
Dim str As String
Dim LR As Long, i As Long, j As Long, k As Long
HN = Array("Age", "Gender Identity", "Ethnicity1", "Ethnicity2")
Set wsS = ThisWorkbook.Sheets("ElementsFile")
Set wsPB = ThisWorkbook.Sheets("ElementsFile")
wsPB.Columns(4).Insert
ReDim CN(0 To UBound(HN))
With wsS
LR = .Range("A" & .Rows.Count).End(xlUp).Row
'Get Array of column numbers coresponding to Header names
For i = 0 To UBound(HN)
j = wsS.Rows(1).Find(HN(i)).Column
CN(i) = j
Next i
End With
ReDim myresult(1 To LR, 1 To 1)
For i = 1 To LR
str = vbNullString
If Not (IsEmpty(Cells(i, CN(0))) And IsEmpty(Cells(i, CN(1)))) Then
For k = UBound(HN) To 0 Step -1
If k <> UBound(HN) Then
str = Cells(i, CN(k)) & "|" & str
Else: str = Cells(i, CN(k)) & str
End If
Next k
myresult(i, 1) = str
Else
myresult(i, 1) = vbNullString
End If
Next i
str = vbNullString
wsPB.Range("D1").Resize(LR, 1) = myresult
End Sub