Excel VBA: determing rows on which the value is found - vba

I am trying to have the row number in which the value was found:
Set rep = Sheets("Details")
For i = 2 To n
If Sheets("Work").Range("A:A").Find(Worksheets("Work_report").Range("E" & i).Value, lookat:=xlWhole) Is Nothing Then
Else:
findrow = Sheets("Work_report").Range("E" & i).Find(Worksheets("Work").Range("A:A").Value, lookat:=xlWhole).Row
o = rep.Range("A" & Rows.Count).End(xlUp).Row + 1
rep.Range("A" & o).Value = "FT_EXCEL"
rep.Range("B" & o).Value = Sheets("Start").Range("C5") & "AB" & Format(o - 1, "00")
rep.Range("C" & o).Value = Sheets("Work_report").Range("E" & findrow)
End If
Next i
For the row I want to use "findrow" which basically would need to find the row in Work_Report. This is only executed if, from sheet Work the cell value was found in Work_Report, so in order to find the number of the row I am trying to invert the line and have it found back in Work_Report, however this gives me the error of - Object variable or With block variable not set.
Thanks!

I prefer MATCH to find on single column searches:
Set rep = Sheets("Details")
Dim test As Long
For i = 2 To n
test = 0
On Error Resume Next
test = Application.WorksheetFunction.Match(Worksheets("Work_report").Range("E" & i).Value, Sheets("Work").Range("A:A"), 0)
On Error GoTo 0
If test > 0 Then
o = rep.Range("A" & Rows.Count).End(xlUp).Row + 1
rep.Range("A" & o).Value = "FT_EXCEL"
rep.Range("B" & o).Value = Sheets("Start").Range("C5") & "AB" & Format(o - 1, "00")
rep.Range("C" & o).Value = Sheets("Work_report").Range("E" & test)
End If
Next i

you can do it in one shot with exploiting AutoFilter() method's operator xlFilterValues value
Sub main()
Dim rep As Worksheet
Dim criteriaArr As Variant
With Worksheets("Work_report") '<--| reference "Work_report" sheet
criteriaArr = Application.Transpose(.Range("E2", .Cells(.Rows.Count, "E").End(xlUp)).Value) '<--| store its column E cells content from row 2 down to last not empty one
End With
Set rep = Sheets("Details")
With Worksheets("Work") '<--| reference "Work" sheet
With .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)) '<--| reference its column A cells from row 1 (header) down to last not empty one
.AutoFilter Field:=1, Criteria1:=criteriaArr, Operator:=xlFilterValues '<--| filter it with "Work_report" sheet column E content
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then '<--| if any filtered cells other then headers
With .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible) '<--| reference filtered cells skipping header
rep.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(.Rows.Count).Value = "FT_EXCEL" '<--| write 'rep' sheet column A corresponding cells content
With rep.Range("B" & Rows.Count).End(xlUp).Offset(1).Resize(.Rows.Count)
.Formula = "=CONCATENATE(Start!$C$5,""AB"",TEXT(ROW(),""00""))" '<--| '<--| write 'rep' sheet column B corresponding cells content
.Value = .Value
End With
End With
End If
End With
.AutoFilterMode = False
End With
End Sub

Related

Split Workbook into multiple workbooks based on two columns

I hope everyone is well.
I am look for some help. I am looking to automate a workbook which splits the data from the master file to the individual workbooks based on column H. What needs to be done first is that Column T needs to be filtered to 'Owned' or 'Impacted'. Column H then needs to be split into the separate workbooks. based on what may be in column H. On each new workbook created, whatever is under column H there needs to be two tabs, one tab for 'Owned' and one tab for 'Impacted'. This would need to be then saved as whatever the name of the cell was and the date.
The additional difficult bit is under column H, in each cell as per the attached there could be A, B, C, D, E, F as individual cells, but there could also be cells with multiple letters in them. If they have multiple letters each one needs to go into all the workbooks that are mentioned in the cell. So, for example if there is a cell with A, B, C, D, this would mean it would have to go into the workbook for the individual workbooks for A, B, C, and D.
I have attached the file image and I have the below code which I used. It does work, however due to the above issue with the multiple criteria in the cells it is splitting the workbooks further into individual workbooks. Does anyone know if a drop down can be added where I can select the criteria from column H and T, or another work around please. I am happy to try another code if necessary. Example workbook attached as well.
Option Explicit
Sub ParseItems()
'Based on selected column, data is filtered to individual workbooks
'workbooks are named for the value plus today's date
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
'Sheet with data in it
Set ws = Sheets("Master")
'Path to save files into, remember the final \
SvPath = "\\My Documents\New folder\"
'Range where titles are across top of data, as string, data MUST
'have titles in this row, edit to suit your titles locale
vTitles = "A1:V1"
'Choose column to evaluate from, column A = 1, B = 2, etc.
vCol = Application.InputBox("What column to split data by? " & vbLf _
& vbLf & "(A=1, B=2, C=3, etc)", "Which column?", 8, Type:=1)
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("HH1"), Unique:=True
'Sort the temporary list
ws.Columns("HH:HH").Sort Key1:=ws.Range("HH2"), 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("HH2:HH" &
Rows.Count).SpecialCells(xlCellTypeConstants))
'clear temporary worksheet list
ws.Range("HH:HH").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)
ws.Range("A1:A" & LR).EntireRow.Copy
Workbooks.Add
Range("A1").PasteSpecial xlPasteAll
Cells.Columns.AutoFit
MyCount = MyCount + Range("A" & Rows.Count).End(xlUp).Row - 1
ActiveWorkbook.SaveAs SvPath & MyArr(Itm) & Format(Date, " MM-DD-YY") &
".xlsx", 51 'use for Excel 2007+
ActiveWorkbook.Close False
ws.Range(vTitles).AutoFilter Field:=vCol
Next Itm
'Cleanup
ws.AutoFilterMode = False
MsgBox "Rows with data: " & (LR - 1) & vbLf & "Rows copied to other sheets:
" & MyCount & vbLf & "Hope they match!!"
Application.ScreenUpdating = True
End Sub
Any help would be appreciated. Thank in advance
Rather than applying filters to the worksheet you could load the entire dataset into an array and then store the row index #s for each of the various criteria. You can then use the row index lists to slice the array for each respective output.
I don't have your source data (couldn't see the attached file) but would this approach work?
Sub VariableCollections()
Dim HeaderVals() As Variant
Dim SourceData() As Variant, Criteria As Variant
Dim RowIndexLists As New Collection, ColIndexList As String
Dim KeyStore As New Collection, Key As Variant
Dim i As Long, Temp As String
Dim fName As String, fFormat As Long
Dim OutputArr() As Variant
On Error GoTo ErrorHandler
Application.ScreenUpdating = False
With Sheets("Master") 'change if necessary
'store table header values in array (A1:W1)
HeaderVals = .Cells(1, 1).Resize(, 23).Value
'store data in array, assume starts at A2
SourceData = .Cells(2, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row, 23).Value
End With
'index row #s for each Criteria & Owned/Impacted
For i = LBound(SourceData, 1) To UBound(SourceData, 1)
If SourceData(i, 23) = "Owned" Then 'col W
'loop each Criteria (col H) for current row
For Each Criteria In Split(SourceData(i, 8), ", ")
'test if key already added to KeyStore
If Not InCollection(KeyStore, Criteria) Then KeyStore.Add Criteria, Criteria
'test if Criteria already added to RowIndexLists
If InCollection(RowIndexLists, Criteria & "_Own") Then 'already added...
'...update row index value for current key
Temp = RowIndexLists(Criteria & "_Own")
RowIndexLists.Remove (Criteria & "_Own")
RowIndexLists.Add Temp & "," & i, Criteria & "_Own"
Else 'not already stored...
'...Create New Item
RowIndexLists.Add i, Criteria & "_Own"
End If
Next Criteria
ElseIf SourceData(i, 23) = "Impacted" Then 'col W
'loop each Criteria (col H) for current row
For Each Criteria In Split(SourceData(i, 8), ", ")
'test if key already added to KeyStore
If Not InCollection(KeyStore, Criteria) Then KeyStore.Add Criteria, Criteria
'test if Criteria already added to RowIndexLists
If InCollection(RowIndexLists, Criteria & "_Imp") Then 'already added...
'...update row index value for current key
Temp = RowIndexLists(Criteria & "_Imp")
RowIndexLists.Remove (Criteria & "_Imp")
RowIndexLists.Add Temp & "," & i, Criteria & "_Imp"
Else 'not already stored...
'...Create New Item
RowIndexLists.Add i, Criteria & "_Imp"
End If
Next Criteria
End If
Next i
'save in same directory as current workbook
fName = Split(ThisWorkbook.FullName, ".")(0)
'set file format # based on OS type
#If Mac Then
fFormat = 52
#Else
fFormat = 51
#End If
'assumes cols 8 (H) and 23 (W) are no longer needed in output
ColIndexList = "1,2,3,4,5,6,7,9,10,11,12,13,14,15,16,17,18,19,20,21,22"
'slice HeaderVals array for matching cols
HeaderVals = Application.Index(HeaderVals, 0, Split(ColIndexList, ","))
'write out to new workbooks
For Each Key In KeyStore
'create new workbook
With Workbooks.Add
'output "Owned" matches for current Criteria (key value) if exist
If InCollection(RowIndexLists, Key & "_Own") Then
'slice array to indexed rows
OutputArr = Application.Index(SourceData, _
Application.Transpose(Split(RowIndexLists(Key & "_Own"), ",")), _
Split(ColIndexList, ","))
'add new worksheet, rename & output data
With .Worksheets.Add(After:=.Sheets(.Sheets.Count))
'rename sheet
.Name = "Owned"
'test if OutputArr has 2 dimensions
If IsArray2D(OutputArr) Then '2D i.e. rows & cols
.Cells(1, 1).Resize(, UBound(OutputArr, 2)) = HeaderVals
.Cells(2, 1).Resize(UBound(OutputArr, 1), UBound(OutputArr, 2)) = OutputArr
Else '1D i.e. single row
.Cells(1, 1).Resize(, UBound(OutputArr)) = HeaderVals
.Cells(2, 1).Resize(, UBound(OutputArr)) = OutputArr
End If
End With
End If
'output "Impacted" matches for current Criteria (key value) if exist
If InCollection(RowIndexLists, Key & "_Imp") Then
'slice array to indexed rows
OutputArr = Application.Index(SourceData, _
Application.Transpose(Split(RowIndexLists(Key & "_Imp"), ",")), _
Split(ColIndexList, ","))
'add new worksheet, rename & output data
With .Worksheets.Add(After:=.Sheets(.Sheets.Count))
'rename sheet
.Name = "Impacted"
'test if OutputArr has 2 dimensions
If IsArray2D(OutputArr) Then '2D i.e. rows & cols
.Cells(1, 1).Resize(, UBound(OutputArr, 2)) = HeaderVals
.Cells(2, 1).Resize(UBound(OutputArr, 1), UBound(OutputArr, 2)) = OutputArr
Else '1D i.e. single row
.Cells(1, 1).Resize(, UBound(OutputArr)) = HeaderVals
.Cells(2, 1).Resize(, UBound(OutputArr)) = OutputArr
End If
End With
End If
'delete sheet1
Application.DisplayAlerts = False
.Sheets(1).Delete
Application.DisplayAlerts = True
'save file & close
.SaveAs fName & "_" & Key, fFormat
.Close
End With
Next Key
ErrorHandler: If Err.Number <> 0 Then MsgBox "Error # " & Err.Number & " " & Err.Description
Application.ScreenUpdating = True
End Sub
as #dwirony suggested it utilizes the Split function on col H to break apart the various criteria on each row and then stores the row # in a collection.
I realize a Dictionary would be a better suited here rather than using Collections, however as Dictionaries are Windows only I prefer to avoid them unless I know for certain the file will only ever be used on Windows. If this is the case then the above code could be simplified by switching the collections out for a dictionary.
#jeeped Excel creates base-1 arrays when directly assigning a Range object to an array. I've always assumed to make them similar to the (ROW,COL) addressing.
==== Edit 6/30 ====
Updated code to reflect changes to data layout:
Additional cols in data range
Owned/Impacted col moved to Col W
Adjusted Worksheet reference to match OPs request

Trying to Highlight Used Range of a Column

I'm running into trouble highlighting a column's used range. The following code creates copies of two worksheets, removes some values and then is supposed to highlight certain columns.
Sub CreateAnalysisSheets()
Dim cell, HlghtRng As Range
Dim i As Integer
Dim ref, findLast, findThis As String
Dim lastRow As Long
findLast = "2016"
findThis = "2017"
Application.ScreenUpdating = False
Sheets(1).Copy After:=Sheets(2)
ActiveSheet.Name = Left(Sheets(1).Name, InStr(1, Sheets(1).Name, " ")) & "Analysis"
Sheets(2).Copy After:=Sheets(3)
ActiveSheet.Name = Left(Sheets(2).Name, InStr(1, Sheets(2).Name, " ")) & "Analysis"
Sheets("RM Analysis").Select
For Each cell In ActiveSheet.UsedRange
If cell.Value = "NULL" Then
cell.ClearContents
End If
Next cell
For Each cell In Range("1:1")
ref = cell.Value
lastRow = Range("R" & Rows.Count & "C" & cell.Column).End(xlUp).Row
Set HlghtRng = Range(Cells(1, cell.Column) & Cells(lastRow, cell.Column))
If InStr(1, ref, findLast) > 0 And InStr(1, ref, "YTD") = 0 Then
HlghtRng.Interior.ColorIndex = 8
End If
Next cell
For Each cell In Sheets(4).UsedRange
If cell.Value = "NULL" Then
cell.ClearContents
End If
Next cell
Sheets("RM Analysis").Select
Application.ScreenUpdating = True
End Sub
The problem comes at lastRow = Range("R" & Rows.Count & "C" & cell.Column).End(xlUp).Row where I get an Method 'Range' of Object '_Global' Failed. I've tried searching for ways to fix this issue, but everything I've tried (ActiveSheet.Range and Sheets("RM Analysis").Range) has yet to work.
Anyone see where I'm going wrong here?
The xlR1C1 syntax is fouling up your request for the last non-blank cell.
lastRow = Cells(Rows.Count, cell.Column).End(xlUp).Row
I would highly recommend that you avoid relying on the ActiveSheet and use explicit parent worksheet references. This can be made quite simple using With ... End With and preceding all Range and Cells with a . like .Range(...) or .Cells(...).
Once you within a With ... End With statement, all of the references need to be prefaced with a .. Additionally, the following is not a string concatenation (e.g. &) but as .Range(starting cell comma ending cell) operation.
with worksheets("RM Analysis")
...
Set HlghtRng = .Range(.Cells(1, cell.Column), .Cells(lastRow, cell.Column))
...
end with
this should do
Columns(1).Interior.ColorIndex = 3
change the number of column as to the column you wanna highlit

Extracting data from pivot table vba

I have a pivot table to aggregate "coverage" on "part" only for accepted parts.
I want then to extract the "sum of coverage" to another sheet.
I wrote the following macro:
Sub Pull_data()
'Update the pivot table
Sheets("Pivot").PivotTables("PivotTable2").PivotCache.Refresh
'clear all filters
Sheets("Pivot").PivotTables("PivotTable2").PivotFields("Accepted").ClearAllFilters
'filters only accepted items
Sheets("Pivot").PivotTables("PivotTable2").PivotFields("Accepted").CurrentPage = "YES"
'get the last row of the pivot table
Set PT = Sheets("Pivot").PivotTables("PivotTable2")
With PT.TableRange1
lngLastRow = .rows(.rows.Count).Row
End With
For i = 4 To lngLastRow
'copy the coverage to destination sheet
NEWi = i + 10
Sheets("Destination").Range("G" & NEWi) = PivotTable.GetPivotData(data_field, Range("I" & i), “Coverage”)
Next i
End Sub
I get a run time error '424', object required on
Sheets("Destination").Range("G" & NEWi) = PivotTable.GetPivotData(data_field, Range("I" & i), “Coverage”)
Which would be the proper way to write that line?
This should be :
Sheets("Destination").Range("G" & i + 10).Value = _
pT.GetPivotData("Sum of coverage", "Part", Range("I" & i).Value).Value
Because pT.GetPivotData returns a Range!
Cleaned code :
Sub Pull_data()
Dim pT As PivotTable
Set pT = Sheets("Pivot").PivotTables("PivotTable2")
With pT
'''Update the pivot table
.PivotCache.Refresh
'''clear all filters
.PivotFields("Accepted").ClearAllFilters
'''filters only accepted items
.PivotFields("Accepted").CurrentPage = "YES"
'''get the last row of the pivot table
With .TableRange1
lngLastRow = .Rows(.Rows.Count).Row
For i = .Cells(2, 1).Row To lngLastRow
Debug.Print "i=" & i & "|" & Sheets("Pivot").Range("I" & i).Value
'''copy the coverage to destination sheet
Sheets("Destination").Range("G" & i + 10).Value = _
pT.GetPivotData("Sum of coverage", "Part", Sheets("Pivot").Range("I" & i).Value).Value
Next i
End With '.TableRange1
End With 'pT
End Sub
You could try copying the entire Column from your PivotTable after it's filtered to your needs, with TableRange2 , use the Resize to a single column, and then Copy and PasteSpecial xlValues to the destination worksheet.
If the code below takes the wrong column, you can also use the Offset(0,1) to get the right one.
With PT
.TableRange2.Resize(.TableRange2.Rows.Count, 1).Copy
Worksheets("Destination").Range("G14").PasteSpecial xlValues '<-- start Pasting from Row 14
End With
Note: if the code above takes the column to the left, try the code line below:
.TableRange2.Resize(.TableRange2.Rows.Count, 1).Offset(, 1).Copy

Compare 4 columns in one excel sheet using vba

I need your help please, I have 4 columns in an excel sheet and I need to compare them 2 by 2 i will explain to you :
In column A i have users(user1,user2,user3 ...)
In column B i have functionalities ( fonc1, fonc2, fonc3.....)
In column C i have users(user1,user2,user3 ...)
In column D i have functionalities ( fonc1, fonc2, fonc3.....)
The columns C and D are a new version of columns A and B in the columns C and D the users may change order or change functionalities .
When i execute my code i put the result in other new columns:
column F where i have the users
column G where i put the Deleted_functionalities
column H where i put the New_functionalities
The first problem is that the code doesn't get the users it get only the new and deleted functionalities. The second problem is that when the column A is more than column C where the users are stocked the code doesn't work. Can you please help me to find a solution? Thank you in advance .
Here is my code and the file I am working on :
Private Sub CommandButton2_Click()
Dim rngCell As Range
For Each rngCell In Range("B2:B2000")
If WorksheetFunction.CountIf(Range("D2:D2000"), rngCell) = 0 Then
Range("G" & Rows.Count).End(xlUp).Offset(1) = rngCell
End If
Next
For Each rngCell In Range("D2:D2000")
If WorksheetFunction.CountIf(Range("B2:B2000"), rngCell) = 0 Then
Range("H" & Rows.Count).End(xlUp).Offset(1) = rngCell
End If
Next
End Sub
and this is the excel file
http://www.cjoint.com/c/FCxnwjp22rv
try this
Private Sub CommandButton2_Click()
Dim ws As Worksheet
Dim cell As Range, funcCell As Range
Dim oldUserRng As Range, newUserRng As Range, reportRng As Range
Dim iReport As Long
Dim oldFunc As String, newFunc As String
Set ws = ThisWorkbook.Worksheets("users") '<== adapt it to your needs
With ws
Set oldUserRng = .Columns(1).Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeConstants, xlTextValues)
Set newUserRng = .Columns(3).Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeConstants, xlTextValues)
Set reportRng = .Range("F1:I1") '<== added one report column to account for unchanged functions
End With
reportRng.Value = Array("user", "deleted", "new", "same")
iReport = 1
For Each cell In oldUserRng
With cell
oldFunc = .Offset(, 1).Value
Set funcCell = FindAndOffset(newUserRng, .Value, 1)
If funcCell Is Nothing Then
reportRng.Offset(iReport) = Array(.Value, "", "", oldFunc)
Else
newFunc = funcCell.Value
If newFunc = oldFunc Then
reportRng.Offset(iReport) = Array(.Value, "", "", newFunc)
Else
reportRng.Offset(iReport) = Array(.Value, oldFunc, newFunc, "")
End If
End If
iReport = iReport + 1
End With
Next cell
For Each cell In newUserRng
With cell
Set funcCell = FindAndOffset(oldUserRng, .Value, 1)
If funcCell Is Nothing Then
reportRng.Offset(iReport) = Array(.Value, "", .Offset(, 1).Value, "")
iReport = iReport + 1
End If
End With
Next cell
End Sub
Not so sure it does what you need.
you'd better provide screenshots of "before" and "after" scenarios.
BTW, is it safe to assume that both old and new user columns cannot hold duplicates (i.e.: two or more "userX" in column A and/or column C?)
But it does speed up thing considerably since it iterates only through non empty cells.
I hope I get what you want to achieve. Does the following solve your problem?
Private Sub CommandButton2_Click()
Dim rngCell As Range
For Each rngCell In Range("A2:A20000")
If WorksheetFunction.CountIf(Range("C2:C20000"), rngCell) > 0 Then
Range("F" & Rows.Count).End(xlUp).Offset(1) = rngCell
Range("F" & Rows.Count).End(xlUp).Offset(0, 1) = rngCell.Offset(0, 1).Value
Range("F" & Rows.Count).End(xlUp).Offset(0, 2) = Application.WorksheetFunction.VLookup(rngCell.Value, Range("C2:D20000"), 2, 0)
ElseIf (rngCell <> "") Then
Range("F" & Rows.Count).End(xlUp).Offset(1) = rngCell
Range("F" & Rows.Count).End(xlUp).Offset(0, 1) = rngCell.Offset(0, 1).Value
End If
Next
For Each rngCell In Range("C2:C20000")
If (WorksheetFunction.CountIf(Range("A2:A20000"), rngCell) = 0 And rngCell <> "") Then
Range("F" & Rows.Count).End(xlUp).Offset(1) = rngCell
Range("F" & Rows.Count).End(xlUp).Offset(0, 2) = rngCell.Offset(0, 1).Value
End If
Next
End Sub
A user is only included in column F when he appears both in columns A and C.In case you want to include every user that is either in column A or C the code has to be altered.

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.