Splitting values within Cell in excel into rows whilst keeping other column data - excel

I want to do the following in a non-manual way:
I have a cell with multiple values separated by line breaks which I want to split up BUT keep the values in the other columns the same.
Thank you

As SJR pointed out, the following should work:
Sub Foo()
'working for active sheet
'copy to the end of sheets collection
ActiveSheet.Copy After:=Sheets(Sheets.Count)
Dim tmpArr As Variant
Dim Cell As Range
For Each Cell In Range("B1", Range("B2").End(xlDown))
If InStr(1, Cell, Chr(10)) <> 0 Then
tmpArr = Split(Cell, Chr(10))
Cell.EntireRow.Copy
Cell.Offset(1, 0).Resize(UBound(tmpArr), 1). _
EntireRow.Insert xlShiftDown
Cell.Resize(UBound(tmpArr) + 1, 1) = Application.Transpose(tmpArr)
End If
Next
Application.CutCopyMode = False
End Sub

Related

Excel VBA: Skip the copied cell in for loop

I have a some data where I have some conditions. If each cell in column B contains words like "and", "or", "and/or", then create a copy of that row and insert it into next row following the copied row.
Currently my data looks like this:
This is my code:
Sub Macro2()
Dim rng As Range, cell As Range, rowRange As Range
Set rng = Range("B1", Range("B1").End(xlDown))
Dim values As Variant
Dim Result() As String
connectorArray = Array("and/or", "or", "and")
Dim findConnectorWord As String
'Worksheets("Sheet1").Activate
'Range("B1", Range("B1").End(xlDown)).Select
For Each cell In rng
findConnectorWord = FindString(cell.Value, connectorArray)
If findConnectorWord <> vbNullString Then
Result() = Split(cell, findConnectorWord)
Set rowRange = Range("A" & cell.Row, Range("B" & cell.Row).End(xlToRight))
rowRange.Copy
rowRange .Offset(1, 0).Insert Shift:=xlDown
'Logic to skip the next cell
End If
Next cell
End Sub
Function FindString(SearchString As String, arr As Variant) As String
For Each searchWord In arr
If InStr(SearchString, searchWord) > 0 Then
FindString = searchWord
Exit For
End If
Next
End Function
The problem that I am having is that once the row is copied and inserted into the next row, the next iteration reads the copied row("Homeowners or Dwelling Fire") and creates another copy. What I would like to do is to skip the cell once the row is copied, inside the if condition and look at Cell B3(Assuming that Umbrella (C) gets pushed down when the new cell is copied over). What's the best possible way to do this?
One of the possible options for implementing what #freeflow wrote about in his comment:
...
Set cell = Range("B1").End(xlDown) ' start from last cell
Do Until False
findConnectorWord = FindString(cell.Value, connectorArray)
If findConnectorWord <> vbNullString Then
...
Set rowRange = cell.EntireRow
rowRange.Copy
rowRange.Offset(1, 0).Insert Shift:=xlDown
End If
If cell.Row = 1 Then Exit Do ' First row? Enough
Set cell = cell.Offset(-1, 0) ' Shift up
Loop
...
And one more note - when defining values ​​for connectorArray, add spaces to the terms: " and " instead of "and". Otherwise, you can duplicate the line with some Brandon or Alexandra

VBA code to copy and paste specifc words in different cells to another worksheet

I have a code that will copy and paste a whole row in worksheet called "Raw Data". If cells in Range $D$1:D have a value of "Thomas Xiong", then it will paste the whole row of everything under that value to another worksheet called "WIP".
What I am trying to do is be able to create a code that will be able to find multiple words. For example, "Thomas Xiong" and the word "Assigned" and be able to copy and paste that whole line from the worksheet "Raw Data" into another worksheet.
Also with the code I have now, it will copy and paste the whole rows but there are spaces in between each cell row in the other worksheet.
The code I have now:
Sub Test()
Dim Cell As Range
With Sheets("Raw Data")
' loop column C untill last cell with value (not entire column)
For Each Cell In .Range("D1:D" & .Cells(.Rows.Count, "D").End(xlUp).Row)
If Cell.Value = "Thomas Xiong" Then
' Copy>>Paste in 1-line (no need to use Select)
.Rows(Cell.Row).copy Destination:=Sheets("WIP").Rows(Cell.Row)
'.Range("C1:C", "A", "B", "D", "F" & Cell.Row).copy
End If
Next Cell
For Each Cell In .Range("C1:C" & .Cells(.Rows.Count, "C").End(xlUp).Row)
If Cell.Value = "Assigned" Then
' Copy>>Paste in 1-line (no need to use Select)
.Rows(Cell.Row).copy Destination:=Sheets("WIP").Rows(Cell.Row)
'.Range("C1:C", "A", "B", "D", "F" & Cell.Row).copy
End If
Next Cell
End With
End Sub
The problem is you are using the row of the cells you are copying in your destination sheet. You want to use a separate counter that you increment every time you paste something on e given row:
Sub Test()
Dim Cell As Range
Dim myRow as long
myRow = 2
With Sheets("Raw Data")
' loop column C untill last cell with value (not entire column)
For Each Cell In .Range("D1:D" & .Cells(.Rows.Count, "D").End(xlUp).Row)
If Cell.Value = "Thomas Xiong" Then
' Copy>>Paste in 1-line (no need to use Select)
.Rows(Cell.Row).copy Destination:=Sheets("WIP").Rows(myRow)
myRow = myRow + 1
End If
Next Cell
For Each Cell In .Range("C1:C" & .Cells(.Rows.Count, "C").End(xlUp).Row)
If Cell.Value = "Assigned" Then
' Copy>>Paste in 1-line (no need to use Select)
.Rows(Cell.Row).copy Destination:=Sheets("WIP").Rows(myRow)
myRow = myRow + 1
End If
Next Cell
End With
End Sub
What's not clear (to me at least) is if you want to only find rows where the value in column D is "Thomas Xiong" and the value in column C is "Assigned", in which case you want to have something like this:
Sub Test()
Dim Cell As Range
Dim myRow as long
myRow = 2
With Sheets("Raw Data")
For Each Cell In .Range("C1:C" & .Cells(.Rows.Count, "C").End(xlUp).Row)
If Cell.Value = "Assigned" and Cell.Offset(0,1).Value = "Thomas Xiong" Then
' Copy>>Paste in 1-line (no need to use Select)
.Rows(Cell.Row).copy Destination:=Sheets("WIP").Rows(myRow)
myRow = myRow + 1
End If
Next Cell
End With
End Sub
To loop through a list of names (which I will assume to be in range A1:A10 in a worksheet called "myNames") something like this should work:
Sub Test()
Dim Cell as Range
Dim NameCell as Range
Dim myRow as Long
myRow = 2
With Sheets("Raw Data")
For each NameCell in Worksheet("myNames").Range("A1:A10)
For Each Cell In .Range("C1:C" & .Cells(.Rows.Count, "C").End(xlUp).Row)
If Cell.Value = "Assigned" and Cell.Offset(0,1).Value = NameCell.Value Then
.Rows(Cell.Row).copy Destination:=Sheets("WIP").Rows(myRow)
myRow = myRow + 1
Exit For
End If
Next Cell
Next NameCell
End With
End Sub

VBA: skip blank cells from processing (with formulas in them)

I have a vba code that copies a file multiple times and renames the output after a list of names in column D from sheet "Linkuire".
Column D is full of concatenate formulas that bring data into cells till D1000.
When the concatenate formulas return "" (as in nothing) i want the code to ignore that cell.
' the range of cells that contain the rename list
With ActiveWorkbook.Sheets("Linkuire")
Set rRenameList = .Range("D2", .Cells(.Rows.Count, "D").End(xlUp))
End With
Now it just takes into account all D2 to D1000 cells even if some are = ""
How can I make the code ignore all cells where the return of the concatenate is "" ? (I have the same problem with a vba code that converts a certain sheet into pdf - with data got from concatenate formulas. It converts all cells even if concatenate return "" and is blank)
Thank you..
edited since pure SpecialCells() approach wouldn't work
You could use following two approaches and avoid looping:
AutoFilter() and SpecialCells() approach:
With ActiveWorkbook.Sheets("Linkuire")
With .Range("D1", .Cells(.Rows.count, "D").End(xlUp))
.AutoFilter Field:=1, Criteria1:="<>" '<--| filter out blanks
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then Set rRenameList = .Resize(.Rows.count - 1).Offset(1).SpecialCells(xlCellTypeVisible)
End With
.AutoFilterMode = False
End With
Formula and SpecialCells() approach
With ActiveWorkbook.Sheets("Linkuire")
With .Range("D2", .Cells(.Rows.count, "D").End(xlUp))
.Offset(, 1).FormulaR1C1 = "=IF(RC[-1]="""", 1,"""")"
Set rRenameList = .Offset(, 1).SpecialCells(xlCellTypeFormulas, xlNumbers).Offset(, -1)
.Offset(, 1).ClearContents
End With
End With
in this approach you're writing a formula in a "helper" column I chose to be the adjacent to the right. It can be adjusted to any other offset
This should work. It will loop through your range, and only add the cell address to your rRenameList when the length is greater than or equal to 1.
Sub Test()
' Adapted from http://stackoverflow.com/a/8320884/4650297
Dim rng1 As Range, rRenameList As Range, cel As Range
With ActiveWorkbook.Sheets("Linkuire")
Set rng1 = .Range("D2", .Cells(.Rows.Count, "D").End(xlUp))
End With
For Each cel In rng1
If Len(cel) >= 1 Then
If Not rRenameList Is Nothing Then
Set rRenameList = Union(rRenameList, cel)
Else
' the first valid cell becomes rng2
Set rRenameList = cel
End If
End If
Next cel
Debug.Print rRenameList.Address
End Sub

Split text in cells at line breaks into rows, for multiple columns

My question is an extension to this, Split text in cells at line breaks, where, I need to split text in cells with line break into separate rows, NOT only for just one column, but for multiple columns.
A screenshot of my data:
Just building on what was done in your linked answer:
Sub JustDoIt2()
'working for active sheet
'copy to the end of sheets collection
ActiveSheet.Copy after:=Sheets(Sheets.Count)
Dim tmpArr As Variant
Dim Cell As Range
For Each Cell In Range("A2", Range("A2").End(xltoright).End(xlDown))
If InStr(1, Cell, Chr(10)) <> 0 Then
tmpArr = Split(Cell, Chr(10))
If Cell.Offset(1) <> Cell Then
Cell.EntireRow.Copy
Cell.Offset(1, 0).Resize(UBound(tmpArr), 1). _
EntireRow.Insert xlShiftDown
End If
Cell.Resize(UBound(tmpArr) + 1, 1) = Application.Transpose(tmpArr)
End If
Next
Application.CutCopyMode = False
End Sub

Copying rows from one Excel sheet to another based on cell value

I'm looking for a simple excel macro that can copy a row from one sheet to another within excel based upon having a specific number/value in the cell. I have two sheets. One called "master" and a sheet called "top10".
Here is an example of the data.
Here's the macro I'm trying to use:
Sub MyMacro()
Dim i As Long, iMatches As Long
Dim aTokens() As String: aTokens = Split("10", ",")
For Each cell In Sheets("master").Range("A:A")
If (Len(cell.Value) = 0) Then Exit For
For i = 0 To UBound(aTokens)
If InStr(1, cell.Value, aTokens(i), vbTextCompare) Then
iMatches = (iMatches + 1)
Sheets("master").Rows(cell.Row).Copy Sheets("top10").Rows(iMatches)
End If
Next
Next
End Sub
I'm sure I'm doing something extremely silly that's causing this not to work. I can run the macro itself without any error, but nothing gets copied to the sheet I'm looking to compile.
If (Len(cell.Value) = 0) Then Exit For is nonsense. Change it like below:
Sub MyMacro()
Dim i As Long, iMatches As Long
Dim aTokens() As String: aTokens = Split("10", ",")
For Each cell In Sheets("master").Range("A:A")
If Len(cell.Value) <> 0 Then
For i = 0 To UBound(aTokens)
If InStr(1, cell.Value, aTokens(i), vbTextCompare) Then
iMatches = (iMatches + 1)
Sheets("master").Rows(cell.Row).Copy Sheets("top10").Rows(iMatches)
End If
Next
End If
Next
End Sub
I believe the reason your code stops after the first row of data is because the cell your are testing in the next row is empty (in your example spreadsheet) and therefore you exit the loop (because Len(cell.Value) = 0). I would suggest a different approach: an advanced filter does exactly what you need, and is faster. In your example spreadsheet, you will need to insert an empty row 2 and put the formula "=10" in cell A2. Then the code below will do what you need (assuming thatmaster is the ActiveSheet):
Sub CopyData()
Dim rngData As Range, lastRow As Long, rngCriteria As Range
With ActiveSheet
' This finds the last used row of column A
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
' Defines the criteria range - you can amend it with more criteria,
' it will still work
' 22 is the number of the last column in your example spreadsheet
Set rngCriteria = .Range(.Cells(1, 1), .Cells(2, 22))
' row 2 has the filter criteria, but we will delete it after copying
Set rngData = .Range(.Cells(1, 1), .Cells(lastRow, 22))
' Make sure the destination sheet is clear
' You can replace sheet2 with Sheets("top10"),
' but if you change the sheet name your code will not work any more.
' Using the vba sheet name is usually more stable
Sheet2.UsedRange.ClearContents
' Here we select the rows we need based on the filter
' and copy it to the other sheet
Call rngData.AdvancedFilter(xlFilterCopy, rngCriteria, Sheet2.Cells(1, 1))
' Again, replacing Sheet2 with Sheets("top10")..
' Row 2 holds the filter criteria so must be deleted
Sheet2.Rows(2).Delete
End With
End Sub
For a reference to advanced filters, check out this link:
http://chandoo.org/wp/2012/11/27/extract-subset-of-data/
As #Ioannis mentioned, your problem is the empty cell in master A3 combined with your If (Len(cell.Value) = 0) Then Exit For
Instead of using an that if to detect the end of your range I used the following code:
LastRow= Sheets("master").Cells(Cells.Rows.Count, "A").End(xlUp).Row
Set MyRange = Sheets("master").Range("A1:A" & LastRow)
The resulting code is this:
Sub MyMacro()
Dim i As Long, iMatches As Long
Dim aTokens() As String: aTokens = Split("10", ",")
Dim LastRow
Dim MyRange
LastRow = Sheets("master").Cells(Cells.Rows.Count, "A").End(xlUp).Row
Set MyRange = Sheets("master").Range("A1:A" & LastRow)
For Each cell In MyRange
For i = 0 To UBound(aTokens)
If InStr(1, cell.Value, aTokens(i), vbTextCompare) Then
iMatches = (iMatches + 1)
Sheets("master").Rows(cell.Row).Copy Sheets("top10").Rows(iMatches)
End If
Next
Next
End Sub
I tested this with your workbook and it works perfectly. :-)

Resources