Matches in multiple columns

[canabill]

The VBA code below matches numbers (indicating 0 or 1) between column A and column B and lists them in single column D. How would I list them in multiple columns (preferably 4) instead?


Public Sub CountA_FillC()

Dim RowA As Long, RowB As Long
Dim UsedRange As Range: Set UsedRange = ActiveSheet.UsedRange
For RowB = 1 To UsedRange.Rows.Count
Dim Count As Long: Count = 0
For RowA = 1 To UsedRange.Rows.Count
If UsedRange(RowA, "A").Value = UsedRange(RowB, "B").Value Then
Count = Count + 1
End If
Next RowA
UsedRange(RowB, "D").Value = Count
Next RowB

End Sub

 

[JackDanIce]

Can you give an example of expected output and if it's a specific sheet and name?

 

[canabill]

Thanks for your reply Jack, it's listed as sheet 1 on Excel although I don't think it or the name matters. There's a total of 80 numbers in column B being matched with numbers in A and I'd like the output to come out in 4 columns of 20...say L1, N1, P1 and R1.

 

[JackDanIce]

Try:

Public Sub CountA_FillC()
    
    Dim LR      As Long
    Dim i       As Long
    Dim x       As Long
    Dim y       As Long
    
    Application.ScreenUpdating = False
    
    LR = Cells(Rows.Count, 1).End(xlUp).Row
    
    With Cells(1, 12).Resize(LR)
        .Formula = "=COUNTIF($A$1:$A$" & LR & ",B1)"
        .Value = .Value
        
        If LR > 20 And LR <= 80 Then
            i = 13: y = 1
            For x = 21 To LR
                Cells(y, i).Value = Cells(x, 12).Value
                Cells(x, 12).ClearContents
                y = y + 1
                If x Mod 20 = 0 Then
                    i = i + 1
                    y = 1
                End If
            Next x
        End If
        
        
    End With


    Application.ScreenUpdating = True
    
End Sub

 

[Rick Rothstein]

Thanks for your reply Jack, it's listed as sheet 1 on Excel although I don't think it or the name matters. There's a total of 80 numbers in column B being matched with numbers in A and I'd like the output to come out in 4 columns of 20...say L1, N1, P1 and R1.

Here is another macro that you can consider...

[table="width: 500"]
[tr]
	[td]Public Sub CountBinA_FillLNPR()
  Dim R As Long, C As Long
  Dim arrA As Variant, arrB As Variant, arrL As Variant, arrN As Variant, arrP As Variant, arrR As Variant
  arrA = Split(Chr(1) & Join(Application.Transpose(Range("A1", Cells(Rows.Count, "A").End(xlUp))), Chr(1) & Chr(2) & Chr(1)) & Chr(1), Chr(2))
  arrB = Split(Chr(1) & Join(Application.Transpose(Range("B1", Cells(Rows.Count, "B").End(xlUp))), Chr(1) & Chr(2) & Chr(1)) & Chr(1), Chr(2))
  ReDim arrL(1 To 1 + UBound(arrB) / 4, 1 To 1)
  ReDim arrN(1 To 1 + UBound(arrB) / 4, 1 To 1)
  ReDim arrP(1 To 1 + UBound(arrB) / 4, 1 To 1)
  ReDim arrR(1 To 1 + UBound(arrB) / 4, 1 To 1)
  On Error Resume Next
  For R = 0 To UBound(arrB) Step 4
    arrL(1 + R / 4, 1) = 1 + UBound(Filter(arrA, arrB(R)))
    arrN(1 + R / 4, 1) = 1 + UBound(Filter(arrA, arrB(R + 1)))
    arrP(1 + R / 4, 1) = 1 + UBound(Filter(arrA, arrB(R + 2)))
    arrR(1 + R / 4, 1) = 1 + UBound(Filter(arrA, arrB(R + 3)))
  Next
  On Error GoTo 0
  Range("L1").Resize(UBound(arrL)) = arrL
  Range("N1").Resize(UBound(arrN)) = arrN
  Range("P1").Resize(UBound(arrP)) = arrP
  Range("R1").Resize(UBound(arrR)) = arrR
End Sub[/td]
[/tr]
[/table]

Note: I assumed there might be data or formulas in Columns M, O and Q, hence, the individual column arrays that I used.

 

[Rick Rothstein]

Here is another macro that you can consider...

[table="width: 500"]
[tr]
	[td]Public Sub CountBinA_FillLNPR()
  Dim R As Long, C As Long
  Dim arrA As Variant, arrB As Variant, arrL As Variant, arrN As Variant, arrP As Variant, arrR As Variant
  arrA = Split(Chr(1) & Join(Application.Transpose(Range("A1", Cells(Rows.Count, "A").End(xlUp))), Chr(1) & Chr(2) & Chr(1)) & Chr(1), Chr(2))
  arrB = Split(Chr(1) & Join(Application.Transpose(Range("B1", Cells(Rows.Count, "B").End(xlUp))), Chr(1) & Chr(2) & Chr(1)) & Chr(1), Chr(2))
  ReDim arrL(1 To 1 + UBound(arrB) / 4, 1 To 1)
  ReDim arrN(1 To 1 + UBound(arrB) / 4, 1 To 1)
  ReDim arrP(1 To 1 + UBound(arrB) / 4, 1 To 1)
  ReDim arrR(1 To 1 + UBound(arrB) / 4, 1 To 1)
  On Error Resume Next
  For R = 0 To UBound(arrB) Step 4
    arrL(1 + R / 4, 1) = 1 + UBound(Filter(arrA, arrB(R)))
    arrN(1 + R / 4, 1) = 1 + UBound(Filter(arrA, arrB(R + 1)))
    arrP(1 + R / 4, 1) = 1 + UBound(Filter(arrA, arrB(R + 2)))
    arrR(1 + R / 4, 1) = 1 + UBound(Filter(arrA, arrB(R + 3)))
  Next
  On Error GoTo 0
  Range("L1").Resize(UBound(arrL)) = arrL
  Range("N1").Resize(UBound(arrN)) = arrN
  Range("P1").Resize(UBound(arrP)) = arrP
  Range("R1").Resize(UBound(arrR)) = arrR
End Sub[/td]
[/tr]
[/table]

Note: I assumed there might be data or formulas in Columns M, O and Q, hence, the individual column arrays that I used.

If the note in the above posting of mine (Message #5 ) does not apply to you (that is, there is no data or formulas in Columns M, O or Q), then you can use this slightly more compact macro...

[table="width: 500"]
[tr]
	[td]Public Sub CountBinA_FillLNPR()
  Dim R As Long, C As Long
  Dim arrA As Variant, arrB As Variant, Arr As Variant
  arrA = Split(Chr(1) & Join(Application.Transpose(Range("A1", Cells(Rows.Count, "A").End(xlUp))), Chr(1) & Chr(2) & Chr(1)) & Chr(1), Chr(2))
  arrB = Split(Chr(1) & Join(Application.Transpose(Range("B1", Cells(Rows.Count, "B").End(xlUp))), Chr(1) & Chr(2) & Chr(1)) & Chr(1), Chr(2))
  ReDim Arr(1 To 1 + UBound(arrB) / 4, 1 To 7)
  On Error Resume Next
  For R = 0 To UBound(arrB) Step 4
    For C = 1 To 7 Step 2
      Arr(1 + R / 4, C) = 1 + UBound(Filter(arrA, arrB(R + (C - 1) / 2)))
    Next
  Next
  On Error GoTo 0
  Range("L1").Resize(UBound(Arr), 7) = Arr
End Sub[/td]
[/tr]
[/table]

 

[canabill]

I have my Excel VBA file to attach but I don't see a button for it.?

 

[Rick Rothstein]

I have my Excel VBA file to attach but I don't see a button for it.?

This forum does not support attachments. You can put your file on DropBox (it's free) and then share the link they give you for your file with us so that we can download it from there.

Can I assume that neither of the macros that I posted worked for you? If so, can you describe in what way they did not work?

 

[canabill]

This forum does not support attachments. You can put your file on DropBox (it's free) and then share the link they give you for your file with us so that we can download it from there.

Can I assume that neither of the macros that I posted worked for you? If so, can you describe in what way they did not work?

Thanks for the info. Your code works (code from message #6 ) for outputting the 1 & 0 matches from columns A & B into the L,N,P and R columns but the matches are incorrect sometimes showing 1's where there should be 0's and vise-versa. What I wanted to show you in the file was the numbers from 1 to 80 (at the output)are in columns K,M,O and Q.

 

[JackDanIce]

Code in #4 does what you need, based on the test sheet I created...

Initially numbers were in cols A & B and your code is using Count = Count + 1, for me it generated values > 1 which outputs into column D

Your ask was to change this single column output, to 4 columns, L:R

Now you're stating you have data in columns K:Q; code in #4 would overwrite this.

You may want to start again with a clean sheet for each piece of code suggested, run and test and then confirm if any code works for you or if none do why - given you're struggling to upload file.

Finally my test data was in cells A1:A40 =ROW() then I copied and pasted these values into A1:B40 and again into A41:B80, so each row would have matching pairs and each pair would exist at least twice in A1:B80