count differences among adjacent cells

[ekalavya]

Hello everyone,

I have a problem that may seem a bit unusual, but I hope someone on this board can help me. I have several columns (can range from 2 to 100+ depending on the data) that have the values either 0 or 1 (absence/presence) for each row (up to 150 rows). I want to count, within each row, how many times the adjacent cells differ in their values, and report the total number of times the changes occur. To explain further, if for Row1 the value changes from 0 to 1 at Column3, I want to count this. If the value changes from 1 to 0 at Column7, I want to count this and add to the first count. And so on till the last column.

If someone could provide a macro to do this, I would be be grateful for your help. Thank you.

Example input:

Data	Col1	Col2	Col3	Col4	Col5	Col6	Col7	Col8	Col10
Row1	1	1	1	1	0	0	1	1	1
Row2	0	0	0	0	NA	1	1	1	1
Row3	1	1	1	1	1	1	1	1	1
Row4	0	0	0	0	0	0	0	0	0
Row5	1	1	1	1	NA	0	0	1	1
Row6	1	1	1	1	1	1	1	1	1
Row7	0	0	0	0	0	0	NA	1	1
Row8	0	0	0	0	0	0	0	0	0
Row9	1	0	1	1	0	0	1	1	0

<tbody>
</tbody>

Desired output:

Row1	2 Changes
Row2	1 Changes
Row3	0 Changes
Row4	0 Changes
Row5	2 Changes
Row6	3 Changes
Row7	1 Changes
Row8	0 Changes
Row9	5 Changes

<tbody>
</tbody>

(The NA need to be skipped and not counted/reported.)

 

[JLGWhiz]

This macro will do what you want.

Sub countChange()
Dim sh1 As Worksheet, sh2 As Worksheet, lr As Long
Set sh1 = Sheets(1) 'Edit sheet name
Set sh2 = Sheets(2) 'Edit sheet name
lr = sh1.Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lr
    With sh1
        For Each c In .Range(.Cells(i, 1), .Cells(i, Columns.Count).End(xlToLeft).Offset(0, -1))
            If c.Value <> c.Offset(0, 1).Value Then
                cnt = cnt + 1
            End If
        Next
        sh2.Cells(Rows.Count, 1).End(xlUp)(2) = "Row " & i
        sh2.Cells(Rows.Count, 1).End(xlUp).Offset(0, 1) = cnt
        cnt = 0
    End With
Next
End Sub

 

[ekalavya]

This macro will do what you want.

Thanks a lot! Appreciate it.

 

[hiker95]

ekalavya,

The below macro will adjust for a varying number of rows in column A, and, columns in row 1.

And, you can change the worksheet names in the macro:

Set w1 = Sheets("Sheet1")
Set w2 = Sheets("Sheet2")

Sample raw data in worksheet Sheet1 (before, and, after the macro):

Excel 2007
	A	B	C	D	E	F	G	H	I
1	1	1	1	1	0	0	1	1	1
2	0	0	0	0	NA	1	1	1	1
3	1	1	1	1	1	1	1	1	1
4	0	0	0	0	0	0	0	0	0
5	1	1	1	1	NA	0	0	1	1
6	1	1	1	1	1	1	1	1	1
7	0	0	0	0	0	0	NA	1	1
8	0	0	0	0	0	0	0	0	0
9	1	0	1	1	0	0	1	1	0
10
Sheet1

After the macro in worksheet Sheet2:

Excel 2007
	A	B
1	Row1	2 Changes
2	Row2	1 Changes
3	Row3	0 Changes
4	Row4	0 Changes
5	Row5	2 Changes
6	Row6	0 Changes
7	Row7	1 Changes
8	Row8	0 Changes
9	Row9	5 Changes
10
Sheet2

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Sub CountChangesInEachRow()
Dim oa As Variant, a As Variant, o As Variant
Dim i As Long, j As Long
Dim w1 As Worksheet, w2 As Worksheet
Dim r As Long, lr As Long, lc As Long, luc As Long, c As Long, n As Long
Application.ScreenUpdating = False
Set w1 = Sheets("Sheet1")
Set w2 = Sheets("Sheet2")
With w1
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  lc = .Cells(1, Columns.Count).End(xlToLeft).Column
  oa = .Range(.Cells(1, 1), .Cells(lr, lc))
  ReDim o(1 To lr, 1 To 2)
  Application.DisplayAlerts = False
  With Range(.Cells(1, 1), .Cells(lr, lc))
    .Replace What:="NA", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    .SpecialCells(xlBlanks).Delete shift:=xlToLeft
  End With
  For r = 1 To lr
    n = 0
    luc = Cells(r, Columns.Count).End(xlToLeft).Column
    For c = 1 To luc - 1
      If .Cells(r, c) <> .Cells(r, c + 1) Then
        n = n + 1
      End If
    Next c
    j = j + 1
    o(j, 1) = "Row" & r
    o(j, 2) = n & " Changes"
  Next r
  .Range(.Cells(1, 1), .Cells(lr, lc)) = oa
End With
With w2
  .UsedRange.ClearContents
  .Cells(1, 1).Resize(lr, 2).Value = o
  .Columns(1).Resize(, 2).AutoFit
  .Activate
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the CountChangesInEachRow macro.