I'm having a issue to get a text result which is a concatenate/join of "X" cells of a column based quantity in another cell. Example:
Cell value = 2
Name
Txt1
Txt2
Txt3
Txt4
Result = Txt1Txt2
Cell value = 3
Name
Txt1
Txt2
Txt3
Txt4
Result = Txt1Txt2Txt3
One must have CONCAT():
=CONCAT(A2:INDEX(A2:A5,C1))
If one does not have CONCAT this UDF will mimic the function. Put this in a module attached to the workbook:
Function CONCAT(rng As Range)
Dim rngArr As Variant
rngArr = rng
On Error GoTo onlyone
Dim itm As Variant
For Each itm In rngArr
CONCAT = CONCAT & itm
Next itm
Exit Function
onlyone:
CONCAT = rngArr
End Function
Related
I'm trying to copy the values of a range of cells(A1:A50) into a single cell (B1). I can do it manually by copying the cells to the clipboard and then pasting the clipboard into the formuala bar of B1 but I can't find a way of doing this in a macro other than getting the cells copied to the clipboard.
Hopefully someone can help me out here.
Sheet1.Range("A1:A50").SpecialCells(xlCellTypeConstants).Select
Selection.Copy
I would like the contents of cell B1 to look something like this:
Value of cell A1
Value of cell A2
Value of cell A3
...and so on
Just
Sub myConcat(rSource As Range, rTarget As Range, Optional sDelimiter = vbCrLf)
Dim oCell As Range
Dim sRes As String
sRes = vbNullString
For Each oCell In rSource
sRes = sRes & sDelimiter & oCell.Text
Next oCell
rTarget.Value = Right(sRes, Len(sRes) - Len(sDelimiter))
End Sub
Call it from your code like as
Sub tst_myConcat()
Call myConcat([A1:A50], [B1])
End Sub
Of course, this procedure can be easily converted to a function:
Function myConcat(rSource As Range, Optional sDelimiter = vbCrLf)
Dim oCell As Range
Dim sRes As String
sRes = vbNullString
For Each oCell In rSource
sRes = sRes & sDelimiter & oCell.Text
Next oCell
myConcat = Right(sRes, Len(sRes) - Len(sDelimiter))
End Function
In this case, just write in the target cell (B1) =myConcat(A1:A50)
Do not forget to include in the cell format Wrap text!
First Column To String
The FirstColumnToString function (UDF) has a fixed delimiter (Delimiter) which can manually be changed. But it can e.g. do the following:
=FirstColumnToString(A1:A2,A4,A6:C8,Sheet2!A1:A3)
where it will discard error values and zero-length strings ("") and choose only values from the first column of each range e.g. in range A6:C8 it will choose the values from A6:A8.
The Code
Option Explicit
Function FirstColumnToString(ParamArray SourceRanges() As Variant) _
As String
Const Delimiter As String = vbLf & vbLf
Dim RangesCount As Long
RangesCount = UBound(SourceRanges) - LBound(SourceRanges) + 1
Dim data As Variant
ReDim data(1 To RangesCount)
Dim Help As Variant
ReDim Help(1 To 1, 1 To 1)
Dim Element As Variant
Dim RowsCount As Long
Dim j As Long
For Each Element In SourceRanges
j = j + 1
If Element.Rows.Count > 1 Then
data(j) = Element.Columns(1).Value
Else
data(j) = Help
data(j)(1, 1) = Element.Columns(1).Value
End If
RowsCount = RowsCount + UBound(data(j))
Next Element
Dim Result As Variant
ReDim Result(1 To RowsCount)
Dim Current As Variant
Dim i As Long
Dim k As Long
For j = 1 To RangesCount
For i = 1 To UBound(data(j))
Current = data(j)(i, 1)
If Not IsError(Current) Then
If Current <> vbNullString Then
k = k + 1
Result(k) = Current
End If
End If
Next i
Next j
ReDim Preserve Result(1 To k)
FirstColumnToString = Join(Result, Delimiter)
End Function
A much simpler way of doing the job is to use the TREXTJOIN function in Excel:
With Sheet2.Range("A1:A50")
.AutoFilter Field:=1, Criteria1:="<>"
Sheet2.Range("B1").Value2 = WorksheetFunction.TextJoin(vbCrLf, True, _
.SpecialCells(xlCellTypeVisible))
.AutoFilter
End With
I am looking for a way to extract addresses / ranges from a formulae. I have created an example formula below.
=SUMIFS(Worksheet_Name!$C$3:$C$20, Worksheet_Name!$A$3:$A$20, "Blue", Worksheet_Name!$B$3:$B$20, "Green")
I am trying to get some sort VBA routine which I can pick apart the formulae.
I would like to get the ranges as follows:
Worksheet_Name!$C$3:$C$20
Worksheet_Name!$A$3:$A$20
Worksheet_Name!$B$3:$B$20
So I can access these separately.
How about the following, this will take a cell as input, then it will strip out anything outside the brackets and split the remainder of the formula by commas into an array, and then it will display then in a Msgbox, but you can adapt that to your needs:
Sub Get_Ranges_In_Formula()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
'declare the worksheet you are working with
Dim rngs As String
Dim arrayofRngs
cellvalue = ws.Range("A1").Formula
'get the formula from the cell
openingParen = InStr(cellvalue, "(")
closingParen = InStrRev(cellvalue, ")")
rngs = Mid(cellvalue, openingParen + 1, closingParen - openingParen - 1)
'strip anything outside the brackets
arrayofRngs = Split(rngs, ",")
'split by comma into array
For i = LBound(arrayofRngs) To UBound(arrayofRngs)
If InStr(arrayofRngs(i), "!") > 0 Then MsgBox arrayofRngs(i)
Next
End Sub
A solution using RegEx to extract cell references from formulas:
Sub Get_Ranges_In_Formula()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim xRetList As Object
Dim xRegEx As Object
Dim I As Long
Dim xRet As String
Dim Rg As Range
Set Rg = ws.Range("A1")
Application.Volatile
Set xRegEx = CreateObject("VBSCRIPT.REGEXP")
With xRegEx
.Pattern = "('?[a-zA-Z0-9\s\[\]\.]{1,99})?'?!?\$?[A-Z]{1,3}\$?[0-9]{1,7}(:\$?[A-Z]{1,3}\$?[0-9]{1,7})?"
.Global = True
.MultiLine = True
.IgnoreCase = False
End With
Set xRetList = xRegEx.Execute(Rg.Formula)
If xRetList.Count > 0 Then
For I = 0 To xRetList.Count - 1
MsgBox xRetList.Item(I)
Next
End If
End Sub
Try this
Sub Test()
Dim e, s As String
s = MyArguments(Range("A1"))
For Each e In Split(s, ",")
If InStr(e, "!") Then Debug.Print Trim(e)
Next e
End Sub
Function MyArguments(rng As Range) As String
MyArguments = Split(Split(rng.Formula, "(")(1), ")")(0)
End Function
I've got the following question:
This line wsMotiv.Range("motiv_naam") = Cells(iRijnummer, iKolomnrNaam).Text gives a name (string) value. Why doesn't the line s = ThisWorkbook.Worksheets(1).Cells(iRijnummer, iKolomnrNaam).Text do the same? It passes " ".
Sub (whatev)
AantalZichtbareRows
Dim rng As Range
Dim row As Range
Dim StrFileName As String
'If Aantalregels > 1 Then
Set rng = Selection.SpecialCells(xlCellTypeVisible)
For Each row In rng.Rows
iRijnummer = row.row
If iRijnummer > 1 Then
Windows(c_SourceDump).Activate
wsMotiv.Range("motiv_cid") = Cells(iRijnummer, iKolomnrCorpID).Text
wsMotiv.Range("motiv_naam") = Cells(iRijnummer, iKolomnrNaam).Text
wsMotiv.Range("motiv_ldg") = Cells(iRijnummer, iKolomnrHuidigeLeidingGevende).Text
Worksheets("stambestand").Activate
'naamOpmaken
Dim s As String: s = ThisWorkbook.Worksheets(1).Cells(iRijnummer, iKolomnrNaam).Text
Dim Position As Long, Length As Long
Dim n As String
Position = InStrRev(s, " ")
Length = Len(s)
n = Right(s, Length - Position)
End If
Next row
End Sub
You are referring to the ActiveSheet in Cells(iRijnummer, iKolomnrNaam).Text and to the first worksheet in ThisWorkbook.Worksheets(1).Cells(iRijnummer, iKolomnrNaam).Text. Probably they are different. Try this to see:
Sub TestMe
Debug.Print wsMotiv.Name
Debug.Print Worksheets(1).Name
Debug.Print ActiveSheet.Name
End Sub
I am putting together a basic macro to format a column to include reference letters. For example, one column has 1,2,3 and there is a cell where the user can input some letters and click a button. ABC for example. This when working shall format 1,2,3 to now be ABC1, ABC2, ABC3 etc.
I have achieved this somewhat but it only works for the letter A. See below:
Sub Macro4()
Range("A3:A60").Select
Selection.NumberFormat = Range("k11").Text & "0" & "0" & "0"
End Sub
Here's my attempt. I'm quite certain there is a better way:
Option Explicit
Sub TestMacro()
Dim MyRange As Range
Dim MyReference As Range
Dim MyArray() As Variant
Dim Counter As Long
Dim wf As WorksheetFunction
Dim Cell As Range
Dim val As Integer
Application.ScreenUpdating = False
Set wf = Application.WorksheetFunction
Set MyRange = Range("A3:A60")
For Each Cell In MyRange
val = Application.Evaluate("=MIN(SEARCH({0,1,2,3,4,5,6,7,8,9}," & Cell.Address & "&" & """0,1,2,3,4,5,6,7,8,9""" & "))")
Cell = CInt(Mid(Cell, val, Len(Cell) - val + 1))
Next Cell
Set MyReference = Range("B3")
MyArray = Application.Transpose(MyRange)
For Counter = LBound(MyArray) To UBound(MyArray)
MyArray(Counter) = MyReference & CStr(MyArray(Counter))
Next Counter
MyRange = Application.Transpose(MyArray)
Application.ScreenUpdating = True
End Sub
I wrote a crude function to select and concatenate cells based on a range.
Function GetSkills(CellRef As String, CellRefEnd As String, Delimiter As String)
Dim CellStart As Range
Dim CellEnd As Range
Dim LoopVar As Long
Dim StartRow As Long
Dim EndRow As Long
Dim Concat As String
Dim Col As Long
Set CellStart = Worksheets(1).Cells.Range("B" & CellRef)
Set CellEnd = Worksheets(1).Cells.Range("B" & CellRefEnd)
Col = CellStart.Column
StartRow = CellStart.Row
EndRow = CellEnd.Row
With Range(CellStart, CellEnd)
.Merge
.WrapText = True
End With
Concat = ""
For LoopVar = StartRow To EndRow
Concat = Concat & Cells(LoopVar, Col).Value
If LoopVar <> EndRow Then Concat = Concat & Delimiter & " "
Next LoopVar
GetSkills = Concat
End Function
Within it I'm trying to merge the cells, when I run the function I get a prompt saying:
The selection contains multiple data values. Merging into once cell
will keep the upper-left most data only
I click OK and Excel crashes, restarts, and prompts the dialog again. Is there another way to merge a block of cells using VBA?
Generally merging cells is not a good idea. It is a cosmetic formatting approach that can cause havoc with VBA code.
Disclaimers aside, a few suggestions
use a Sub rather than a Function given you want to work with altering the range
use Application.DisplayAlerts to suppress the merge cells message
you can cut down the code significantly
code
Sub Test()
Call GetSkills(2, 4, ",")
End Sub
Sub GetSkills(CellRef As String, CellRefEnd As String, Delimiter As String)
Dim CellStart As Range
Dim CellEnd As Range
Dim Concat As String
Application.DisplayAlerts = False
Set CellStart = Worksheets(1).Cells.Range("B" & CellRef)
Set CellEnd = Worksheets(1).Cells.Range("B" & CellRefEnd)
Concat = Join(Application.Transpose(Range(CellStart, CellEnd)), Delimiter)
With Range(CellStart, CellEnd)
.Merge
.WrapText = True
.Value = Concat
End With
Application.DisplayAlerts = True
End Sub