I'm working on a google spreadsheet with something like this (it's a single column):
1
2
3,4
5
6-9
15
18
3,4 is 3 and 4
6-9 is 6, 7, 8 and 9
On another sheet I made a standard 1-100 list and I have to find a way to "mark" the numbers that appears or that are included on the previous list, like this.
1 YES
2 YES
3 YES
4 YES
5 YES
6 YES
7 YES
8 YES
9 YES
10 NO
11 NO
12 NO
13 NO
14 NO
15 YES
I can easily find the simple unique numbers by using in cell B1:
=IF((COUNTIF(list!$A$1:$A$100,VALUE(A1))=1),"YES","NO")
I can even find what the first number is:
=IFERROR(LEFT(list!$A$1:$A$100,(SEARCH(",",list!$A$1:$A$100)-1)),IFERROR(LEFT(list!$A$1:$A$100,(SEARCH("-",list!$A$1:$A$100)-1)),list!$A$1:$A$100))
But I can't expand the search to include the numbers between the "x-y" or after the comma in "x,y".
I've tried AND("bigger than 1st number","smaller than 2nd number") but I haven't found a way to extract the second number.
Any suggestion?
Here is a macro that will work for an excel spreadsheet. You can adapt it to Google apps script:
Sub IsItThere()
Dim s1 As Worksheet, s2 As Worksheet, N As Long
Dim v As Variant, i As Long, ary()
Dim N1 As Long, N2 As Long, j As Long
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")
s1.Activate
N = Cells(Rows.Count, "A").End(xlUp).Row
Dim c As Collection
Set c = New Collection
For i = 1 To N
v = Cells(i, 1).Value
If InStr(1, v, ",") > 0 Then
c.Add CLng(Split(v, ",")(0))
c.Add CLng(Split(v, ",")(1))
ElseIf InStr(1, v, "-") > 0 Then
N1 = CLng(Split(v, "-")(0))
N2 = CLng(Split(v, "-")(1))
For j = N1 To N2
c.Add j
Next j
Else
c.Add CLng(v)
End If
Next i
ReDim ary(1 To c.Count)
For i = 1 To c.Count
ary(i) = c.Item(i)
Next i
s2.Activate
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To N
v = Cells(i, 1).Value
For j = 1 To c.Count
If v = ary(j) Then
Cells(i, 2).Value = "YES"
GoTo pass
End If
Next j
Cells(i, 2).Value = "NO"
pass:
Next i
End Sub
Related
I am trying to produce a co-occurrence matrix in an Excel File. My data looks like this:
person1 A
person1 B
person2 A
person2 C
person2 D
person3 A
person3 B
person4 A
person4 C
...
But what I need is essentially a co-occurrence matrix that looks like this (it counts how often any of the combos between A-D occured):
A B C D
A 0 2 2 1
B 2 0 0 0
C 2 0 0 1
D 1 0 1 0
I unfortunately cannot find a useful VBA or Macro or any other approach (I am a beginner with VBA) - so if you have any idea how I could do this, please share.
I tried doing a Pivot but I cannot put the second column of the data on both of the two axis.
In R I would do this with crossprod() but I cannot get the data out of a save environment and cannot install R there either...
Many thanks!
Use a dictionary with column B as key, collection of column A as value. Iterate the combinations and count the matches. Results written to Sheet2.
Option Explicit
Sub CoOccurence()
Dim dict As Object, k, ar, m, v1, v2
Set dict = CreateObject("Scripting.Dictionary")
Dim lastrow As Long, i As Long, j As Long
Dim a As String, b As String
With Sheet1
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To lastrow
a = .Cells(i, "A")
b = .Cells(i, "B")
If Not dict.exists(b) Then
dict.Add b, New Collection
End If
dict(b).Add a
Next
End With
' results
ar = dict.keys
i = dict.Count
ReDim m(1 To i, 1 To i)
With Sheet2
For i = 1 To UBound(m)
' headers
.Cells(1, i + 1) = ar(i - 1)
.Cells(i + 1, 1) = ar(i - 1)
' counts
For j = 1 To UBound(m, 2)
a = ar(i - 1)
b = ar(j - 1)
m(i, j) = 0
If a <> b Then
For Each v1 In dict(a)
For Each v2 In dict(b)
If v1 = v2 Then m(i, j) = m(i, j) + 1
Next
Next
End If
.Cells(i + 1, j + 1) = m(i, j)
Next
Next
End With
MsgBox "Done"
End Sub
Problem description
I have a couple of worksheets showing open and close values per group (track).
All rows come with a date.
I want to loop through all worksheet and grab the oldest value for column Open and the most recent value for column Close.
Pseudo code:
Oldest and newest value per group for first worksheet
Per worksheet, grab the oldest value for Open and the most recent value for Close per group
Go to next worksheet and compare values
Next, go to the next worksheet and compare the oldest and new values with the previously captured ones. Per group, override the oldest value with the corresponding value in the current worksheet if the date in the current worksheet is older.
Override the most recent value with the corresponding value if the date in the current worksheet is more recent.
Repeat step 2 until we've looped through all worksheets.
I've been able to capture the oldest and most recent values per worksheet.
However, I can't figure out how to loop through all the worksheets and grab the oldest and most recent values per group over all worksheets.
I'm a starter on Excel VBA and want to stick with simple loops as per my current code. I want to loop through the worksheets "as is" meaning no renaming and no merging into one worksheet before running any code (there could be over a million rows in total).
Current code to grab the values per worksheet:
Sub top_one()
Dim WS As Worksheet
Dim group_start As Double
Dim track As String
Dim start_date, end_date As Long
Dim opening, closing As Double
For Each WS In ThisWorkbook.Worksheets
If WS.Name <> "1" And WS.Name <> "Expected" Then
WS.Select
With WS
LastRow = Cells(.Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
group_start = 2
If .Cells(i + 1, "A").Value <> .Cells(i, "A").Value Then
group_start = i - group_counter
track = .Cells(i, "A")
start_date = .Cells(group_start, "B")
opening = .Cells(group_start, "C")
end_date = .Cells(i, "B")
closing = .Cells(i, "D")
'lastRowTotal = Sheets("1").Cells(.Rows.Count, "P").End(xlUp).Row
Sheets("1").Cells(j + 2, "A") = .Cells(i, "A") 'trck
'If opening_date < Sheets("1").Cells(j + 2, "B") Then
Sheets("1").Cells(j + 2, "B") = opening_date
'Else
'End If
Sheets("1").Cells(j + 2, "B") = .Cells(group_start, "B") 'start date
Sheets("1").Cells(j + 2, "C") = .Cells(i, "B") 'end date
Sheets("1").Cells(j + 2, "D") = .Cells(group_start, "C") 'opening
Sheets("1").Cells(j + 2, "E") = .Cells(i, "D") 'closing
j = j + 1
group_counter = 0
Else
group_counter = group_counter + 1
End If
Next
j = 0
End With
End If
Next WS
End Sub
Screendumps
Worksheets data
Worksheet called 2018
Track Date Open Close
A 20180101 1 5
A 20180102 4 8
A 20180103 4 5
B 20180104 12 1
B 20180105 2 4
C 20180106 5 2
C 20180107 2 5
E 20180108 8 9
Worksheet called a
Track Date Open Close
A 20170101 5 6
A 20170102 6 6
B 20170103 2 1
B 20170104 1 2
C 20170105 5 9
C 20170106 9 7
D 20170107 5 5
D 20170108 5 8
D 20170109 7 2
Worksheet called 145jki
Track Date Open Close
A 20160101 8 5
A 20160102 4 5
B 20160103 11 5
B 20160104 8 9
C 20160105 10 3
C 20160106 5 7
Expected result
Track Start date End date First Open Last Close
A 20160101 20180103 8 5
B 20160103 20180105 11 4
C 20160105 20180107 10 5
D 20170107 20170109 5 2
E 20180108 20180108 8 9
Try this code
Sub Grab_First_Last_Occurence_Per_Group_Across_Worksheets()
Dim ws As Worksheet
Dim a() As Variant
Dim temp As Variant
Dim prev As Variant
Dim f As Boolean
Dim i As Long
Dim p As Long
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
With ws
If .Name <> "1" And .Name <> "Expected" Then
temp = ws.Range("A2:D" & ws.Cells(Rows.Count, 1).End(xlUp).Row).Value
If f Then
a = ArrayJoin(a, temp)
Else
a = temp
f = True
End If
End If
End With
Next ws
BubbleSort a, 2
BubbleSort a, 1
ReDim b(1 To UBound(a, 1), 1 To 5)
For i = 1 To UBound(a, 1)
If a(i, 1) <> prev Then
p = p + 1
b(p, 1) = a(i, 1)
b(p, 2) = a(i, 2)
b(p, 3) = a(i, 2)
b(p, 4) = a(i, 3)
b(p, 5) = a(i, 4)
If p > 1 Then
b(p - 1, 3) = a(i - 1, 2)
b(p - 1, 5) = a(i - 1, 4)
End If
prev = a(i, 1)
End If
Next i
With Sheets("1")
.Range("A1").Resize(1, 5).Value = Array("Track", "Start Date", "End Date", "First Open", "Last Close")
.Range("A2").Resize(p, UBound(b, 2)).Value = b
End With
Application.ScreenUpdating = True
End Sub
Function ArrayJoin(ByVal a, ByVal b)
Dim i As Long
Dim ii As Long
Dim ub As Long
ub = UBound(a, 1)
a = Application.Transpose(a)
ReDim Preserve a(1 To UBound(a, 1), 1 To ub + UBound(b, 1))
a = Application.Transpose(a)
For i = LBound(b, 1) To UBound(b, 1)
For ii = 1 To UBound(b, 2)
a(ub + i, ii) = b(i, ii)
Next ii
Next i
ArrayJoin = a
End Function
Function BubbleSort(arr() As Variant, sortIndex As Long)
Dim b As Boolean
Dim i As Long
Dim j As Long
ReDim v(LBound(arr, 2) To UBound(arr, 2)) As Variant
Do
b = True
For i = LBound(arr) To UBound(arr) - 1
If arr(i, sortIndex) > arr(i + 1, sortIndex) Then
b = False
For j = LBound(v) To UBound(v)
v(j) = arr(i, j)
arr(i, j) = arr(i + 1, j)
arr(i + 1, j) = v(j)
Next
End If
Next i
Loop While Not b
End Function
I have two columns in Excel with different values:
A 1
B 2
C 3
Now, I would need to pair each cell of first column with each cell of second column. So it would look like this:
A 1
A 2
A 3
B 1
B 2
B 3
C 1
C 2
C 3
Do you know how can I do this please?
Thank you heaps
With data in columns A and B try this short macro:
Sub MakeCombinations()
Dim Na As Long, Nb As Long
Dim i As Long, j As Long, K As Long
Dim rc As Long
K = 1
rc = Rows.Count
Na = Cells(rc, 1).End(xlUp).Row
Nb = Cells(rc, 2).End(xlUp).Row
For i = 1 To Na
For j = 1 To Nb
Cells(K, 3) = Cells(i, 1)
Cells(K, 4) = Cells(j, 2)
K = K + 1
Next j
Next i
End Sub
EDIT#1:
To do this without VBA, in C1 enter:
=INDEX(A:A,ROUNDUP(ROW()/COUNTA(B:B),0),1)
and copy down and in D1 enter:
=INDEX(B:B,MOD(ROW()-1,COUNTA(B:B))+1,1)
and copy down:
I modify Gary's answer with array. Not tested due to my Mac without Excel.
Sub MakeCombinations()
Dim Ary_a As Variant, Ary_b As Variant, Ary as Variant
Dim i As Long, j As Long
Ary_a = range(Cells(rows.count, 1).End(xlUp).Row, 1).value
Ary_b = range(Cells(rows.count, 2).End(xlUp).Row, 2).value
For i = lbound(ary_a) To ubound(ary_a)
For j = lbound(ary_b) To ubound(ary_b)
if not isarray(ary) then
redim ary(1, 0)
else
redim preserve ary(1, ubound(ary, 2)+1)
end if
ary(0, ubound(ary, 2)) = ary_a(i)
ary(1, ubound(ary, 2)) = ary_b(j)
Next j
Next i
cells(1, 4).resize(ubound(ary, 2)+1, ubound(ary, 1)+1).value = application.transpose(ary)
End Sub
I have a large amount of data spread throughout 3 columns on a worksheet in excel. I want to match identical values in columns A & B while keeping values associated with column B inline with their respective B components. Here is an example:
What I have-
A B C
1 a g '
2 b h *
3 c a ?
4 d e $
5 e b /
6 f j )
7 g c #
8 h d #
9 i
10 j
What I am looking to achieve:
A B C
1 a a ?
2 b b /
3 c c #
4 d d #
5 e e $
6 f
7 g g '
8 h h *
9 i
10 j j )
I found this code, but it doesn't also carry over the 3rd column values.
Sub Macro1()
Dim rng1 As Range
Set rng1 = Range([a1], Cells(Rows.Count, "A").End(xlUp))
rng1.Offset(0, 1).Columns.Insert
With rng1.Offset(0, 1)
.FormulaR1C1 = _
"=IF(ISNA(MATCH(RC[-1],C[1],0)),"""",INDEX(C[1],MATCH(RC[-1],C[1],0)))"
.Value = .Value
End With
End Sub
Any help would be greatly appreciated!
Thanks
You will have to store the values in memory (a variant array seems appropriate), then clear the values and work through A1:A10 looking for matches to the first rank of the array.
Sub aaMacro1()
Dim i As Long, j As Long, lr As Long, vVALs As Variant
With ActiveSheet
lr = .Cells(Rows.Count, 1).End(xlUp).Row
vVALs = Range("B1:C" & lr)
Range("B1:C" & lr).ClearContents
For i = 1 To lr
For j = 1 To UBound(vVALs, 1)
If vVALs(j, 1) = .Cells(i, 1).Value Then
.Cells(i, 2).Resize(1, 2) = Application.Index(vVALs, j)
Exit For
End If
Next j
Next i
End With
End Sub
It would probably be best if you tested that on a copy of your data as it does remove the values from B1:C10 before returning them.
I'm a Macro novice - just figured out how to add the developer tab, so sorry if my question is dumb. I have a list of items in Column A and quantity in Column B. I want to copy Columns A and B to Columns D and E, but only if the value in Column B > 0 - and I want them to stack, no blank spaces for the quantity = 0 ones. I found some code online:
Sub copyAboveZero()
Dim sourceRng As Range
Dim cell As Range
Dim i As Long
Set sourceRng = ActiveSheet.Range("B6:B24")
i = 6
For Each cell In sourceRng
If cell.Value > 0 Then
cell.Resize(1, 2).Copy Destination:=Range("D" & i)
i = i + 1
End If
Next cell
End Sub
The problem is that in this example, the quantity was in the first cell. This one is copying Columns B and C, and I want it to copy A and B. What do I need to change? Also, can you paste special values only? I don't want the formatting to come with it.
How about:
Sub KopyKat()
Dim N As Long, i As Long
Dim j As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
j = 1
For i = 1 To N
If Cells(i, "B").Value > 0 Then
Range(Cells(i, "A"), Cells(i, "B")).Copy Cells(j, "D")
j = j + 1
End If
Next i
End Sub
EDIT#1:
This addresses your comments:
Sub KopyKat()
Dim N As Long, i As Long
Dim J As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
J = 6
For i = 6 To N
If Cells(i, "B").Value > 0 And Cells(i, "B") <> "" Then
Range(Cells(i, "A"), Cells(i, "B")).Copy
Cells(J, "D").PasteSpecial (xlValues)
J = J + 1
End If
Next i
End Sub