Splitting cell with multiple data into multiple rows in more than 1 column - vba

I have a sheet with multiple data in 1 cell this happen in a couple of columns. What I need to do is split the cell into individual rows while still keep the details from the other columns
Screen 1 shows the data i got
http://imageshack.com/a/img845/1783/wxc8.png (Screen 1)
Screen 2 is what i wish the macro to output.
http://imageshack.com/a/img842/7356/7yra.png (screen 2)
The macro i found and edited in only allows me to split 1 column and i can't get the editing of the range right. the columns that needs to be split is "J" "K" "N" and "O". The columns "A"- "I" and "L""M" just needs to copy their content to the new row.
Thank you in advance for the help.
Here the Macro im using
Sub Splt1()
Dim LR As Long, i As Long
Dim X As Variant
Application.ScreenUpdating = False
LR = Range("J" & Rows.Count).End(xlUp).Row
Columns("J").Insert
For i = LR To 1 Step -1
With Range("K" & i)
If InStr(.Value, Chr(10)) = 0 Then
.Offset(, -1).Value = .Value
Else
X = Split(.Value, Chr(10))
.Offset(1).Resize(UBound(X)).EntireRow.Insert
.Offset(, -1).Resize(UBound(X) - LBound(X) + 1).Value = Application.Transpose(X)
End If
End With
Next i
Columns("K").Delete
LR = Range("J" & Rows.Count).End(xlUp).Row
With Range("L1:M" & LR)
On Error Resume Next
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
On Error GoTo 0
.Value = .Value
End With
Application.ScreenUpdating = True
End Sub

The problem appears to be the with operator. It constrains your selection. Try reformulating your macro without the with and refer to the the ranges direct. For example, replace your first for loop with something like this:
For i = LR To 1 Step -1
If InStr(Range("K" & i).Value, Chr(10)) = 0 Then
Range("K" & i).Offset(, -1).Value = Range("K" & i).Value
'Range("J" ...
'Range("N" ...
'Range("O" ...
Else
K_collection = Split(Range("K" & i).Value, Chr(10))
Range("K" & i).Offset(1).Resize(UBound(K_collection)).EntireRow.Insert
Range("K" & i).Offset(, -1).Resize(UBound(K_collection) - LBound(K_collection) + 1).Value = Application.Transpose(K_collection)
'J_collection = Split(Range("J"...
'N_collection = Split(Range("N"...
'O_collection = Split(Range("O"...
End If
Next i
In general I avoid with because it tends to obscure the visual pattern of code.
You might also consider eliminating the .INSERT and .DELETE columns, and overwrite directly to the cells. When working with more than one at a time, it becomes hard to keep track which column is temporary and which one is the source. But that all depends on your preference.
Copying values for the other columns should be easy compared to this.

Related

Excel VBA Loop That Not Stops Based On Activecell Value

I have a loop that needs to stop when activecell value is "BBSE", but it passes the cell and continues the loop. someone can help me with that?
I cut rows from table in one workbbok and paste it to another. before the list in column F I have many blank cells, and because of that I am usind xldown.
Here is the relevant code:
'Illuminators Worksheet
OP_wb.Activate
Range("F2").End(xlDown).Select
Do Until ActiveCell.Value = "BBSE"
OP_wb.Activate
Worksheets("Optic Main").Activate
Range("F2").End(xlDown).Select
Selection.EntireRow.Cut
Demand_WB.Activate
Worksheets("Illuminators").Activate
Range("A" & Rows.Count).End(xlUp).Offset(1).Select
ActiveSheet.Paste
Loop
Here is where I want to stop the loop in the red circle:
this is why I am using END.xlDown
If I understand what you are trying to achieve correctly, I believe the following will achieve it:
Dim startRow As Long
Dim endRow As Long
With OP_wb.Worksheets("Optic Main")
startRow = .Range("F2").End(xlDown).Row
endRow = .Columns("F").Find(What:="BBSE", LookIn:=xlValues, LookAt:=xlWhole).Row
.Rows(startRow & ":" & endRow).Cut
End With
With Demand_WB.Worksheets("Illuminators")
.Range("A" & .Rows.Count).End(xlUp).Offset(1).Insert Shift:=xlDown
End With
May be try like this...
'Mentioning Starting Row Here
x = 2
Do
'x refers to Row and F refer to column name
With Cells(x, "F")
'Exiting Do Loop once it finds the matching value using If statement
If .Value = "BBSE" Then Exit Do
OP_wb.Activate
Worksheets("Optic Main").Activate
.EntireRow.Cut
Demand_WB.Activate
Worksheets("Illuminators").Activate
Range("A" & Rows.Count).End(xlUp).Offset(1).Select
ActiveSheet.Paste
End With
'Incrementing row number here to move on to next row
x = x + 1
Loop

VBA - Loading master workbook using another workbook

I got these 2 tables, 1 is a datatable, the 2nd is a instruction table.
everyday i will update the instruction table, and run the macro, which will update the datatable accordingly based on ID.
It is currently really simple. If datatable ID (Col A) matches instructiontable ID (Col J) then the corresponding data Col B-F will update according to instructiontable.
Datatable
Col A= ID
Col B-G = Different names
The instruction table is:
Col I is add (change to Y) or delete (change to N) Col K i
Col J is ID
COl K indicates which name (Header of Col B-G) to update.
Sub updatedatatable()
On Error Resume Next
Dim instructionlastrow, findtablecolumn, findtablerow As Long
Dim findid As Integer
instructionlastrow = Range("I" & Rows.Count).End(xlUp).Row
For i = 2 To instructionlastrow
findid = 0
If Range("I" & i).Value = "Add" And Range("A:A").Find(Range("J" & i).Value).Row = 0 Then
Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1).Value = Range("J" & i).Value
findtablecolumn = Rows(1).Find(Range("K" & i)).Column
findtablerow = Range("A:A").Find(Range("J" & i)).Row
Cells(findtablerow, findtablecolumn).Value = "Y"
ElseIf Range("I" & i).Value = "Add" And Range("A:A").Find(Range("J" & i).Value).Row <> 0 Then
findtablerow = Range("A:A").Find(Range("J" & i)).Row
findtablecolumn = Rows(1).Find(Range("K" & i)).Column
Cells(findtablerow, findtablecolumn).Value = "Y"
ElseIf Range("I" & i).Value = "Remove" And Range("A:A").Find(Range("J" & i).Value).Row <> 0 Then
findtablerow = Range("A:A").Find(Range("J" & i)).Row
findtablecolumn = Rows(1).Find(Range("K" & i)).Column
Cells(findtablerow, findtablecolumn).Value = "N"
End If
Next i
End Sub
i was wandering if anyone can teach me so that the Instruction table can be loaded from a different workbook.
Thanks
I'm not sure excactly what the relation of the two tables are supposed to be according to your description, but I understand as this; you currently have them in the same workbook (in the same worksheet?) but want to have them in different workbooks.
To access a workbook from another workbook in vba you can use the Workbooks.Open method
https://msdn.microsoft.com/en-us/library/office/ff194819.aspx
I can also recommend some code examples from Ron de Bruin
http://www.rondebruin.nl/win/section3.htm
Since you haven't made any coding attempts to access separate workbooks I'm not 100% what you want to do, but please have a look at the links, make an attempt at a solution and get back if you get stuck again.

If column A contains x AND column B contains y THEN add value

I'm very new to macros (it's been a few days now!) but slowly working my way through. I'd like to create a macro that adds a value of 2 to a cell if column D contains the text "(2)" AND column AG contains the text "Adult".
I've created a macro that so far changes the value of the cell to 5 (instead of adding to it) if column D contains the text "(2)" - I've spent a while messing around with "And" functions but I can't seem to find a way to make it take into account the both the "(2)" text in the D column and the "Adult" text in the AG column (I can only make it search one or the other).
Here's my attempt (this doesn't include any of my failed attempts to include the "Adult" text):
Sub BUBFindGuests()
Dim SrchRng As Range
lastRow = Range("D" & Rows.Count).End(xlUp).Row
Set SrchRng = Range("D1:D" & lastRow, "AG1:AG" & lastRow)
For Each cel In SrchRng
If InStr(1, cel.Value, "(2)") > 0 Then
With cel.Offset(0, 39)
.Offset(-1, 0) = "5"
End With
End If
Next cel
End Sub
I'm basically just trying to work out how to include the "Adult" text from the AG column, and also how to make the macro add rather than change the end value. I'm also relatively certain that some parts of my code are unnecessary or clunky, but with my level of experience I'm unsure of how to correct that. Any help would be much appreciated.
Judging by your code, you want to add 2 to column C, if that's the case this should do the trick:
Sub BUBFindGuests()
lastRow = Sheets("SHEETNAME").Range("D" & Rows.Count).End(xlUp).Row
For x = 1 to lastRow
If InStr(1, Sheets("SHEETNAME").Cells(x, 4), "(2)") <> 0 _ 'Checks column D
And Instr(1, Sheets("SHEETNAME").Cells(x, 33), "Adult") <> 0 Then 'Checks column AG
Sheets("SHEETNAME").Cells(x, 3).Value = _
Sheets("SHEETNAME").Cells(x, 3).Value + 2 'Change 3 to the appropriate column
End If
Next x
End Sub
You can search for Adult just as you searched for the (2). Just use the InStr-function two times and combine the result-booleans. You can do that in two ways, logical with And or nested with two if-statements:
If InStrResult1 **And** InStrResult2 Then 'do stuff End If
If InStrResult1 Then If InStrResult2 Then 'do stuff End If End If
Sorry for the bad formation.
You can then store the current value of your cell in a variable. Then add 2 to that variable (myVariable = myVariable + 2) and then set its value to your cell instead of 5.
EDIT: It turns out I misread your question. See revised code.
Sub BUBFindGuests()
Dim SrchRng As Range
lastRow = Range("D" & Rows.Count).End(xlUp).Row
Set SrchRng = Range("D1:D" & lastRow, "AG1:AG" & lastRow)
For Each cel In SrchRng
If InStr(1, cel.Value, "(2)") > 0 And InStr(1, cel.Value, "Adult") > 0 Then cel.Offset(-1, 39).Value = .Offset(-1, 0).Value & "5"
Next cel
End Sub

1004: Application defined error when trying to examine cell contents

I am trying to loop through the rows in my sheet, adding cells B-F of the current row to a range to be copied to another sheet. The cells in the row (B-F) should only be added to the range if the value in column G is "Active" and if the value in column C has a value (not empty/nothing/null/!#VALUE...)
I've tried several ways around it, but I keep getting 1004: App/Object defined error off the first If statement
The msgbox shows me the range is valid, I've tried qualifying to the tiniest detail and also using Cells() instead of .range to no avail.
MsgBox (ActiveWorkbook.Worksheets("Staging").range("G" & Cells(rows.Count, 5).End(xlUp).Row).Value)
For i = Cells(rows.Count, 5).End(xlUp).Row To i = 1 Step -1
If ActiveWorkbook.Worksheets("Staging").Cells("G" & i).Value = "Active" Then
If Not IsError(ActiveWorkbook.Worksheets("Staging").range("C" & i)) Then
Set selectRange = range("B" & i & ":F" & i)
Set copyRange = Union2(copyRange, selectRange)
Else
'Do Nothing
End If
Else
'Do Nothing
End If
Next
Am I just missing something simple here? I've been banging my head over this for hours now.
...and for you eagle eyes out there, Union2 isn't a typo, just a user defined function to avoid not being able to join ranges set to "Nothing"
Try the following:
Change the second line to
For i = Cells(rows.Count, 5).End(xlUp).Row To 1 Step -1
Change the third line to
If ActiveWorkbook.Worksheets("Staging").Range("G" & i).Value = "Active" Then
To start change:
If ActiveWorkbook.Worksheets("Staging").Cells("G" & i).Value = "Active" Then
To
If ActiveWorkbook.Worksheets("Staging").Range("G" & i).Value = "Active" Then
Or
If ActiveWorkbook.Worksheets("Staging").Cells(i , 7).Value = "Active" Then
You also need to fully qualify all your ranges as alot of your ranges are pointing to the active sheet and NOT "staging" Unless it is the active sheet, but just to be sure you should use the following code:
With ActiveWorkbook.Worksheets("Staging")
MsgBox (.Range("G" & .Cells(.Rows.Count, 5).End(xlUp).Row).Value)
For i = .Cells(.Rows.Count, 5).End(xlUp).Row To 1 Step -1
If .Range("G" & i).Value = "Active" Then
If Not IsError(.Range("C" & i)) Then
Set SelectRange = .Range("B" & i & ":F" & i)
Set copyRange = Union(copyRange, SelectRange)
Else
'Do Nothing
End If
Else
'Do Nothing
End If
Next
End With
Also You are using copyRange in this scope without it being declared, I am assuming you are assigning it to a range earlier in your code but if not please make sure to do that.
This is wrong:
ActiveWorkbook.Worksheets("Staging").Cells("G" & i).Value
You can use these:
ActiveWorkbook.Worksheets("Staging").Cells(i, 6)
ActiveWorkbook.Worksheets("Staging").range(cells(i, 6), cells(i, 6)).value
ActiveWorkbook.Worksheets("Staging").range("G" + strings.trim(str(i))).value
I was getting the below Error:
Go to Home -> Select the cell for which you are getting Error-> Use clear all funtion to clear the method.
I executed the script again and it started working fine.

Excel-Macro to fill serial numbers to filtered data

I have 3 columns A,B & C. The data is in B & C. I filter Column C to show "Unique records only". Now I want to add serial numbers to this filtered data in Column A. Be advised that the number of rows in the list (and therefore the filtered list) is not fixed.
I know the function (=SUBTOTAL(3,$B$1:B2)-1 ) but this requires manual intervention. I also found the VBA code that works on an unfiltered list:
Sub FillSerialNumbers()
With Range("A3:A" & Range("B" & Rows.Count).End(xlUp).Row)
.Cells(1, 1).Value = 1
.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1, Trend:=False
End With
End Sub
However I'm unable to implement it on a filtered list. Any help would be appreciated.
Here is another way
Set rRng = Range("A3:A" & Range("B" & Rows.Count).End(xlUp).Row)
Dim cntr As Integer: cntr = 1
For Each cell In rRng
If cell.EntireRow.Hidden = False Then
Cells(cell.Row, 1).Value = cntr
cntr = cntr + 1
End If
Next
As a formula solution, you could try, in cell A3 and copied down:
=IF(AND(COUNTIF(C$3:C3,C3)=1,C3<>""),max(A$2:A2)+1,"")