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
Related
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
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
I have a workbook that has 14 tabs. I want to rename 4 of the tabs. The tabs to be renamed will use cell values on a different tab that contain no illegal characters or length restrictions.
I researched but only found where the cell values are in the same spot on each workbook.
If the cell value is blank or 0, I want to hide the tab.
Worksheets to be renamed:
Summary 1
Summary (2)
Summary (3)
Summary (4)
Worksheet with cell values for renaming:
Overall Summary
cell A24 for Summary 1
cell A25 for Summary (2)
cell A26 for Summary (3)
cell A27 for Summary (4)
Sheets("Summary 1").Name = Sheets("Overall Summary").Range("A24").Value
Etc...
For the cells that have blanks, you'll have to be careful with hide because you might have more than one.
Example:
If Sheets("Overall Summary").Range("A24").Value = <> then
For Each ws In ThisWorkbook.Worksheets
If InStr(1, ws.Name, "Hide_", vbTextCompare) Then
i = i + 1
End If
Next ws
Sheets("OldName").Name = "Hide_" & i
End If
This one will hopefully do what you're looking for.
It looks through each sheet in the ActiveWorkbook and if the name contains "Summary" it will move down into column A of the "Overall Summary" sheet and attempt to grab the new name you want to add.
If the cell it’s looking at in "Overall Summary" is 0 or blank, it will rename that summary sheet to "Hide X" but note that it could just hide the sheets for you instead :)
Sub RenameSummary()
Dim objRegex
Set objRegex = CreateObject("vbscript.regexp")
Dim offset As Long
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
If InStr(LCase$(ws.name), "summary") > 0 Then
With objRegex
.Global = True
.Pattern = "[^\d]+"
offset = CLng(.Replace(ws.name, vbNullString))
End With
With sheets("Overall Summary").Range("A" & (23 + offset))
If Len(.Value2) = 0 Or .Value2 = 0 Then
ws.name = "HIDE " & .row
'ws.Visible = xlSheetHidden 'can directly hide sheet
Else
ws.name = .Value2
End If
End With
End If
Next ws
End Sub
You could try this
Sub Trythis()
Dim cell As Range
For Each cell in Worksheets("Overall Summary").Range("A24:A27") ‘ loop through relevant range of “Overall Summary” sheet
If Not IsEmpty(cell) And cell.Value <> 0 Then ‘ if current cell isn’t neither empty nor zero
Select Case cell.Row ‘check for current cell value and act accordingly
Case 24
Sheets("Summary 1").Name = cell.Value
Case 25
Sheets("Summary (2)").Name = cell.Value
Case 26
Smeets("Summary (3)").Name = cell.Value
Case 27
Sheets("Summary (4)").Name = cell.Value
End Select
End If
Next
End Sub
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
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. :-)