I'm having an excel issue for which I can't seem to find an efficient solution. Excel-file looks like this:
What I want to do is past the text from rows that don't begin with 2023 or 2022 after the text on the previous line. So in this example, the text from row 2 should be pasted after the the text from row 1.
Does anyone have an idea on how to solve this?
Input (column A, no header, sheet "Sheet1"):
A
2023
a
b
2022
2022
2023
a
b
c
d
2022
a
2022
Code:
Sub merge()
Dim rng As Range, arr() As Variant, resultArr() As Variant, separator As String
Set rng = Worksheets("Sheet1").Range("A1:A13")
arr = rng
ReDim resultArr(1 To UBound(arr), 1 To UBound(arr, 2))
separator = ", "
Dim writeRow As Long, testValue As String
For i = 1 To UBound(arr)
testValue = Left(arr(i, 1), 4)
If testValue = "2022" Or testValue = "2023" Then
writeRow = writeRow + 1
resultArr(writeRow, 1) = arr(i, 1)
Else
resultArr(writeRow, 1) = resultArr(writeRow, 1) & separator & arr(i, 1)
End If
Next i
rng = resultArr
End Sub
Output (the original data is overwritten, let me know if this is not desired behavior):
A
2023, a, b
2022
2022
2023, a, b, c, d
2022, a
2022
In case you wanted this to behave differently from how it does now, please ask.
Related
I have two different excel sheets and trying to filter all the prices related to each fruit listed in sheet2.
Sheet1
Sheet2
As you can see, Orange price - 12 is not appearing in the sheet2.
Expected Result
LookupCSVResults function
Option Explicit
Function LookupCSVResults(lookupValue As Variant, lookupRange As Range, resultsRange As Range) As String
Dim s As String
Dim sTmp As String
Dim r As Long
Dim c As Long
Const strDelimiter = "|||"
s = strDelimiter
For r = 1 To lookupRange.Rows.Count
For c = 1 To lookupRange.Columns.Count
If lookupRange.Cells(r, c).Value = lookupValue Then
sTmp = resultsRange.Offset(r - 1, c - 1).Cells(1, 1).Value
If InStr(1, s, strDelimiter & sTmp & strDelimiter) = 0 Then
s = s & sTmp & strDelimiter
End If
End If
Next
Next
s = Replace(s, strDelimiter, ",")
If Left(s, 1) = "," Then s = Mid(s, 2)
If Right(s, 1) = "," Then s = Left(s, Len(s) - 1)
LookupCSVResults = s
End Function
Any suggestions would be appreciable.
Without seeing what the formula used on Sheet2 to get the list for Oranges, what I think that you have done is just copied down the formula from the cell above. This has the effect of moving the cells that the formula references down by one.
So I think that your formula for Orange is currently:
=LookupCSVResults(A2,Sheet1!B3:B10,Sheet1!C3:C10)
And is therefore not looking at the first row of data, which is for Orange.
Your formula should actually be:
=LookupCSVResults(A2,Sheet1!B2:B9,Sheet1!C2:C9)
which will return "12,8,9" as expected. A similar situation will probably occur for "Peach", but this is not being shown as an error.
You may want to used absolute cell positions:
=LookupCSVResults(Sheet2!A2,Sheet1!$B$2:$B$9,Sheet1!$C$2:$C$9)
Regards,
Here's the table I'm working with:
I am manually inputting the "True" in column B for this project. For the example, I manually input column A, but the goal is to get the same results just from referencing column B.
I need it to count up, starting with 166 and add to the number string until it either hits a true, a double true (true back to back), or a double blank (blank cells back to back). For example, the first cell in column B is blank, the second cell is "True", and the third cell is blank - so it input 166, 167. If it went blank > True > True, the input would be 167, 168, 169 in the first three rows.
There can never be more than two trues in a row, only one or two. If there is two blanks in a row then only one number would be input (see 179).
I need to input the same contents (166, 167 for example) until either the blank>true>blank, blank>true>true, or blank>blank condition is met. Then it starts a new string and inputs based on the next condition, and so on.
Apologies for the row #'s being one off if that's confusing... the row numbers have no affect on the #'s in column A, need it to just reference column B.
Thank you for your time.
I think I got it to work. Please check out the code below. It should be installed in the code sheet of the worksheet on which you want the result.
Private Sub Worksheet_Change(ByVal Target As Range)
' Variatus #STO 07 Apr 2020
Dim Arr As Variant
Dim Rng As Range
Dim Result As String
Dim R As Long, Ra As Long
With Target
If .Cells.CountLarge > 1 Then Exit Sub
Set Rng = Range(Cells(2, 2), Cells(Rows.Count, 2).End(xlUp).Offset(1))
If Not Application.Intersect(Target, Rng) Is Nothing Then
Arr = Range(Cells(1, 1), Cells(Rows.Count, 2).End(xlUp).Offset(1)).Value
For R = 2 To Rng.Rows.Count
If Result = "" Then Result = ResultString(Result, R, Arr)
Arr(R, 1) = Result
Cells(R, 1).Value = Result
If R < UBound(Arr) Then
If Arr(R + 1, 2) = False Then
Result = ResultString(Result, R + 1, Arr)
End If
End If
Next R
End If
End With
End Sub
Private Function ResultString(ByVal Seed As Variant, _
ByVal R As Long, _
Arr As Variant) As String
' Variatus #STO 07 Apr 2020
Const Start As Integer = 166
Dim Fun As String
Dim Sp() As String
Dim i As Integer
On Error Resume Next
Sp = Split(Seed, ",")
Seed = Val(Sp(UBound(Sp))) + 1
If Err.Number Then Seed = Start
Fun = Seed
On Error GoTo 0
Do While (R + i) < UBound(Arr)
i = i + 1
If Arr(R + i, 2) = False Then Exit Do
Fun = Fun & ", " & CStr(Val(Seed) + i)
Loop
ResultString = Fun
End Function
The event procedure responds to changes in column B and will build column A according to the entries - True and False (or blank) - found there. The entire column must be rebuilt on each change. Observe the Const Start As Integer = 166 containing the start number.
I have an excel sheet which has just over a thousand lines and I need to be delete all ROWS in it which are as follows:
column A, B,C,D,E,F AND G MUST be an exact match.
Column H (hours) must have a negative value which matches the same value but positive forming a pair, then the pair is deleted.
so the following is an example of a match:
date prod Item Title Code person number hours
2016 xxx 123 test a12d John Smith 78901 8
2016 xxx 123 test a12d John Smith 78901 -8
2016 xxx 123 test a12d John Smith 78901 -8
2016 xxx 123 test a12d John Smith 78901 -42
resulting in:
date prod Item Title Code person number hours
2016 xxx 123 test a12d John Smith 78901 -8
2016 xxx 123 test a12d John Smith 78901 -42
I'm having trouble explaining it let alone writing a macro!
Dim LR As Long
Dim i As Long
'Remove rows
LR = Range("H" & Rows.Count).End(xlUp).Row
For i = LR To 1 Step -1
'How do i compare it against other rows?
Next i
One way to do this would be to join all of the columns together using a delimiter and add it to a dictionary as the key. This will only hold unique values. You could then split each one back into columns again and overwrite the whole sheet. There wold be many other ways to achieve this though and this is just an example of one way you could do it. Also, as always if you do try this try it first on a copy of your original data in case of any unexpected behaviour
Option Explicit
Public Sub ExampleRemoveDuplicates()
Dim dict As Object
Dim temp As String
Dim calc As String
Dim headers As Variant
Dim NoCol As Long, i As Long, j As Long
Dim c, key
With Application
.ScreenUpdating = False
calc = .Calculation
.Calculation = xlCalculationManual
End With
Set dict = CreateObject("Scripting.Dictionary")
' Change this to the sheet that is applicable
With Sheet1
NoCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
' Assumes first row of sheet is headers
headers = .Range(.Cells(1, 1), .Cells(1, NoCol)).Value2
For Each c In .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1))
ReDim arr(1 To NoCol)
temp = vbNullString
j = 1
Do
arr(j) = c.Offset(0, j - 1).Value2
If j = 8 Then
temp = temp & Abs(arr(j))
Else
temp = temp & arr(j)
End If
j = j + 1
Loop Until j = NoCol + 1
If Not dict.exists(temp) And Not temp = vbNullString Then dict.Add key:=temp, Item:=arr
Next c
.Cells.ClearContents
.Range(.Cells(1, 1), .Cells(1, NoCol)).Value2 = headers
i = 1
ReDim Results(1 To dict.Count, 1 To NoCol)
For Each key In dict.keys
For j = 1 To NoCol
Results(i, j) = dict(key)(j)
Next j
i = i + 1
Next key
With .Cells(1, 1)
.Range(.Offset(1, 0), .Offset(dict.Count, NoCol - 1)) = Results
End With
End With
With Application
.Calculation = calc
.ScreenUpdating = True
End With
End Sub
I think (meaning I didn't test :-)) this should do the job.
Option Explicit
Sub DeleteMatchingRow()
' 30 Mar 2017
Dim Rl As Long
Dim R As Long
Application.ScreenUpdating = False
With ActiveSheet
Rl = .Range("H" & .Rows.Count).End(xlUp).Row
For R = Rl To 2 Step -1
If FindMatch(CompString(.Rows(R)), Val(.Cells(R, 8).Value), R) Then
.Rows(R).EntireRow.Delete
End If
Next R
End With
Application.ScreenUpdating = Treu
End Sub
Private Function FindMatch(ByVal Comp1 As String, _
ByVal Gval As Integer, _
ByVal LR As Long) As Long
' 30 Mar 2017
' return the row number where a match was found
' or return 0, if no match was found
Dim R As Long
Dim Comp2 As String
With ActiveSheet
For R = LR To 1 Step -1
Comp2 = CompString(.Rows(R))
If StrComp(Comp1, Comp2, vbBinaryCompare) = 0 Then
If .Cells(R, 8).Value = (Gval * -1) Then
FindMatch = R
Exit Function
End If
End If
Next R
End With
End Function
Private Function CompString(Row As Range) As String
' 30 Mar 2017
Dim Fun As String
Dim C As Long
With Row
For C = 1 To 7
Fun = Fun & CStr(.Cells(C).Value)
Next C
End With
CompString = Fun
End Function
The code prepares two strings consisting of A+B+C+D+E+F (all as strings, not numbers) and compares them. If they are identical, the value in column G is compares with its pendent in the match row * -1. If the two values are identical the row is identified as a match.
The function CompString prepares the comparison strings. The function FindMatch finds the match, and the main routine DeleteMatchingRow does the deleting. I don't have the data to test it on, but in theory it sounds good, doesn't it?
You can use the following function to get a visual of rows which you consider matching but the code doesn't.
Private Sub TestMatch()
' 31 Mar 2017
Dim R As Long
R = 3
With ActiveSheet
Debug.Print CompString(.Rows(R)), "Column G has "; .Cells(R, 8).Value
End With
End Sub
Paste this code in the same code sheet as the function CompString. Make sure that the sheet from which you want to read a line is active (look at it before switching to the VBE window). Replace the value 3 in the code with the number of the row you wish to read. The compare string will be printed in the VB Editor's Immediate Window (press Ctl+G if you don't see it). Repeat the exercise with the other string. You can then compare them visually and determine why VBA considers them different.
I need to propagate cell values to a row, it's sort of difficult to explain...
I have a cell which is always going to be populated with binary values, for example "01110011"
the number changes according to other formulas.
what I need to do is take similar adjacent values and populate a raw with them...
a picture is worth a thousand words I suppose...
http://s28.postimg.org/mf42j9ftp/223.jpg
So basically I need to take the A1 cell and split it across a row...
and I have no idea what so ever how it's done.
I think you will find the LEFT, RIGHT, and MID functions useful. If you were to put all the values that you need to split, like 01110011 (the binary string you used as an example), in column A, you could split it in columns B, C, D and E with the following formulas:
Column B:
=LEFT($A1,1)
Column C:
=MID($A1,2,3)
Column D:
=MID($A1,5,2)
Column E:
=RIGHT($A1,2)
The LEFT function takes a cell as the first argument and the number of characters you want from that cell starting with the leftmost character. The RIGHT function does the same but from the rightmost character. The MID function takes the cell as the first argument, the index of the character you wish to begin from as the second argument, and the number of characters you wish to return as the third argument.
This should help you
Sub splitCell()
Dim cellContent As String
Dim partOfCell As String
Dim columnCounter As Integer
'just to be sure set row format as text to support 00
Rows(2).ClearContents
Rows(2).NumberFormat = "#"
cellContent = CStr(Cells(1, 1))
columnCounter = 1
If Len(cellContent) > 0 Then
partOfCell = Mid(cellContent, 1, 1)
End If
For i = 2 To Len(cellContent)
If Mid(cellContent, i, 1) = Mid(partOfCell, 1, 1) Then
partOfCell = partOfCell + Mid(cellContent, i, 1)
Else
Cells(2, columnCounter) = partOfCell
partOfCell = Mid(cellContent, i, 1)
columnCounter = columnCounter + 1
End If
Next i
Cells(2, columnCounter) = partOfCell
End Sub
Try this option as well,
Sub ListStringIntoB()
'Loop through string, list characters into Starting B1 and over
Dim str As String, Cnt As Integer, A1 As Range, Lp As Integer
Dim col As Long, Rng As Range, r As Range
Set A1 = Range("A1")
str = A1
Cnt = Len(A1)
For Lp = 1 To Cnt
col = Cells(1, Columns.Count).End(xlToLeft).Column + 1
Set Rng = Cells(1, col)
Rng = Mid(str, Lp, 1)
Next Lp
End Sub
Thank you guys for trying to help, I finally found the answer to my predicament... I had to use this code to do the trick..
Sub SplitBinaryNumbers()
Dim Bin As Variant
Bin = Application.Transpose(Split(Replace(Replace(Range("A8").Value, "01", "0,1"), "10", "1,0"), ","))
With Range("A20").Resize(UBound(Bin))
.NumberFormat = "#"
.Cells = Bin
End With
End Sub
I hope this helps someone.
I need to find a way to split some data on excel: e.g.
If a cell has the following in: LWPO0001653/1654/1742/1876/241
All of the info after the / should be LWPO000... with that number.
Is there anyway of separating them out and adding in the LWPO000in? So they come out as LWPO0001653
LWPO0001654
etc etc
I could do manually yes, but i have thousands to do so would take a long time.
Appreciate your help!
Here is a solution using Excel Formulas.
With your original string in A1, and assuming the first seven characters are the one's that get repeated, then:
B1: =LEFT($A1,FIND("/",$A1)-1)
C1: =IF(LEN($A1)-LEN(SUBSTITUTE($A1,"/",""))< COLUMNS($A:A),"",LEFT($A1,7)&TRIM(MID(SUBSTITUTE(MID($A1,8,99),"/",REPT(" ",99)),(COLUMNS($A:A))*99,99)))
Select C1 and fill right as far as required. Then Fill down from Row 1
EDIT: For a VBA solution, try this code. It assumes the source data is in column A, and puts the results adjacent starting in Column B (easily changed if necessary). It works using arrays within VBA, as doing multiple worksheet read/writes can slow things down. It will handle different numbers of splits in the various cells, although could be shortened if we knew the number of splits was always the same.
Option Explicit
Sub SplitSlash()
Dim vSrc As Variant
Dim rRes As Range, vRes() As Variant
Dim sFirst7 As String
Dim V As Variant
Dim COL As Collection
Dim I As Long, J As Long
Dim lMaxColCount As Long
Set rRes = Range("B1") 'Set to A1 to overwrite
vSrc = Range("a1", Cells(Rows.Count, "A").End(xlUp))
'If only a single cell, vSrc won't be an array, so change it
If Not IsArray(vSrc) Then
ReDim vSrc(1 To 1, 1 To 1)
vSrc(1, 1) = Range("a1")
End If
'use collection since number of columns can vary
Set COL = New Collection
For I = 1 To UBound(vSrc)
sFirst7 = Left(vSrc(I, 1), 7)
V = Split(vSrc(I, 1), "/")
For J = 1 To UBound(V)
V(J) = sFirst7 & V(J)
Next J
lMaxColCount = IIf(lMaxColCount < UBound(V), UBound(V), lMaxColCount)
COL.Add V
Next I
'Results array
ReDim vRes(1 To COL.Count, 1 To lMaxColCount + 1)
For I = 1 To UBound(vRes, 1)
For J = 0 To UBound(COL(I))
vRes(I, J + 1) = COL(I)(J)
Next J
Next I
'Write results to sheet
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
With rRes
.EntireColumn.Clear
.Value = vRes
.EntireColumn.AutoFit
End With
End Sub
I'm clearly missing the point :-) but anyway, in B1 and copied down to suit:
=SUBSTITUTE(A1,"/","/"&LEFT(A1,7))
Select ColumnB, Copy and Paste Special, Values over the top.
Apply Text to Columns to ColumnB, Delimited, with / as the delimiter.
There's a couple of ways to solve this. The quickest is probably:
Assuming that the data is in column A:
Highlight the column, go to Data>>Text To Columns
Choose "Delimited" and in the "Other" box, put /
Click ok. You'll have your data split into multiple cells
Insert a column at B and put in the formula =Left(A1, 7)
Insert a column at C and pit in formula =Right(A1, Length(A1)-7)
You'll now have Column B with your first 7 characters, and columns B,C,D,E,F, etc.. with the last little bit. You can concatenate the values back together for each column you have with =Concatenate(B1,C1), =Concatenate(B1,D1), etc..
A quick VBa, which does nearly the same thing that #Kevin's does as well. I wrote it before I saw his answer, and I hate to throw away work ;)
Sub breakUpCell()
Dim rngInput As Range, rngInputCell As Range
Dim intColumn As Integer
Dim arrInput() As String
Dim strStart As String
Dim strEnd As Variant
'Set the range for the list of values (Assuming Sheet1 and A1 is the start)
Set rngInput = Sheet1.Range("A1").Resize(Sheet1.Range("A1").End(xlDown).Row)
'Loop through each cell in the range
For Each rngInputCell In rngInput
'Split up the values after the first 7 characters using "/" as the delimiter
arrInput = Split(Right(rngInputCell.Value, Len(rngInputCell.Value) - 7), "/")
'grab the first 7 characters
strStart = Left(rngInputCell.Value, 7)
'We'll be writing out the values starting in column 2 (B)
intColumn = 2
'Loop through each split up value and assign to strEnd
For Each strEnd In arrInput
'Write the concatenated value out starting at column B in the same row as rngInputCell
Sheet1.Cells(rngInputCell.Row, intColumn).Value = strStart & strEnd
'Head to the next column (C, then D, then E, etc)
intColumn = intColumn + 1
Next strEnd
Next rngInputCell
End Sub
Here is how you can do it with a macro:
This is what is happening:
1) Set range to process
2) Loop through each cell in range and check it isn't blank
3) If the cell contains the slash character then split it and process
4) Skip the first record and concatenate "LWPO000" plus the current string to adjacent cells.
Sub CreateLWPO()
On Error Resume Next
Application.ScreenUpdating = False
Dim theRange
Dim cellValue
Dim offset As Integer
Dim fields
'set the range of cells to be processed here
Set theRange = range("A1:A50")
'loop through each cell and if not blank process
For Each c In theRange
offset = 0 'this will be used to offset each item found 1 cell to the right (change this number to this first column to be populated)
If c.Value <> "" Then
cellValue = c.Value
If InStr(cellValue, "/") > 0 Then
fields = Split(cellValue, "/")
For i = 1 To UBound(fields)
offset = offset + 1
cellValue = "LWPO000" & fields(i)
'if you need to pad the number of zeros based on length do this and comment the line above
'cellValue = "LWPO" & Right$(String(7, "0") & fields(i), 7)
c.offset(0, offset).Value = cellValue
Next i
End If
End If
Next
Application.ScreenUpdating = True
End Sub