VBA: Select rows two by two ?

[YourBroLucas]

Hello,

I have an exported, filtered list of results (not a table) where one out of two rows (the second one) describes the first one.

Now I'd like to select these pairs of rows dynamically in order to format their borders, among other things.

I'd like, for instance, to give the impression of a table by setting a gray background color (thus one pair out of two; meaning rows 2 & 3; 6 & 7; 10 & 11...)

I've sought solutions on various forums but don't seem to be able to find dynamic and repetitive selections that do not involve the entire list.

Whoever would be kind enough to share their wisdom would have my undying gratitude ♥

You may not have the solution, but any hint might help.

Thank you in advance

 

[Joe4]

No need for VBA. Can be done quite easily with Conditional Formatting.

Select the entire range you want to apply this to, then go to Conditional Formatting, select the formula option, enter this formula:

=ISODD(INT(ROW()/2))

and choose your gray formatting color.

If you really want VBA, you can apply this same Conditional Formatting via VBA.
You can get most of the code your need for that using the Macro Recorder to record yourself performing the steps I laid out for you.

 

[YourBroLucas]

Hello Joe,

Thank you for your answer!

I've tried to apply your solution but I got stuck due to the range being dynamic.

Also, I am not familiar with ISODD despite further research online.

I found a way around it which may not be short, but it is efficient and dynamic.

In essence it:
(A.) Applies format to second rows on each pair (thus row 1's bottom edge = row 2's top edge)
(B.) Finds second row of one pair out of two and applies background
(C.) Same as (B.) but with -1 to find first row.

Thank you for your support though !

For rPair = rngT.Rows.Count + 1 To 2 Step -2
    With rngT.Rows(rPair).Columns("A:M")
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Borders(xlEdgeLeft).Weight = xlMedium
            .Borders(xlEdgeRight).Weight = xlMedium
            .Borders(xlEdgeBottom).Weight = xlMedium
    End With
Next rPair
For rPair = rngT.Rows.Count + 1 To 2 Step -4
    With rngT.Rows(rPair).Columns("A:M").Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.149998474074526
        .PatternTintAndShade = 0
    End With
    With rngT.Rows(rPair - 1).Columns("A:M").Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.149998474074526
        .PatternTintAndShade = 0
    End With
Next rPair

 

[YourBroLucas]

I must add that, before doing this, I tried to find an alternative with "If X MOD 2 = 0 Then" as well as For loops, for each loops...

Since I lack proper experience of these functions, it appears to me that I find myself writing longer than needed sections.

But as they say, "It ain't stupid if it works!".

 

[Joe4]

Also, I am not familiar with ISODD despite further research online.

The ISODD function is simply a function that tells you whether a number is an odd number or not.

I found a way around it which may not be short, but it is efficient and dynamic.

On the contrary, note that Loops are EXTREMELY inefficient (one of the most inefficient things in VBA).
Sometimes you have to use them, but if you have a choice of using something else, it is usually better to avoid using loops.

If you have a defined range like "rngT", you can apply the Conditional Formatting on the whole range at once with no loops like this (note most of this code is easily gotten from the Macro Recorder - record yourself applying the formula I initially gave you - then simply replace all instances of "Selection" with "rngT").

    rngT.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=ISODD(INT(ROW()/2))"
    rngT.FormatConditions(rngT.FormatConditions.Count).SetFirstPriority
    With rngT.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.149998474074526
    End With
    rngT.FormatConditions(1).StopIfTrue = False

So as you can see, it is easy to do this with no loops needed!

 

[YourBroLucas]

I replaced my section with yours but it does not apply the format.
I produces no runtime error, just applies no color.

Out of curiosity, is the /2 in the ISODD formula supposed to select only "one odd row number out of two"?

On a sidenote, rngT goes from first row below headers to last row +1 (+1 because the added blank row below last result is/may be... blank)

 

[Joe4]

I replaced my section with yours but it does not apply the format.
I produces no runtime error, just applies no color.

It is kind of tough for us to tell what you code is doing because you only posted a small snippet of it, so we cannot see what the other sections (like the part that calculates "rngT") are doing.
Also, it is difficult without seeing what your data looks like, or what you want your expected results to look like.
It would be great if you could show us samples of both, so we aren't left guessing.

MrExcel has a tool called “XL2BB” that lets you post samples of your data that will allow us to copy/paste it to our Excel spreadsheets, so we can work with the same copy of data that you are. Instructions on using this tool can be found here: XL2BB Add-in

Note that there is also a "Test Here” forum on this board. This is a place where you can test using this tool (or any other posting techniques that you want to test) before trying to use those tools in your actual posts.

Out of curiosity, is the /2 in the ISODD formula supposed to select only "one odd row number out of two"?

If you break the function down by each part, it should become apparent what it is doing.
See the grid below. Note that working from left-to-right, I start off with just the row number (ROW() will return the row number that the formula is located in), and add the next function to it:

So the last column is the completed function. Notice the pattern? That is the exact pattern you want (alternating TRUE/FALSE in blocks of two).

 

[YourBroLucas]

See the grid below.

Makes sense with the INT function, that's clever!

Following your reply, here's the full macro below

Option Explicit

Sub CustomExport()

' Part One: Filter and export
  Dim shtGen As Worksheet, shtTotal As Worksheet
  Dim cDir, cType
  Dim lr As Long
  Dim lrt As Long

  Set shtGen = ActiveWorkbook.Worksheets("Tab_Général")
  Set shtTotal = ActiveWorkbook.Worksheets("RECAP_TOTAL")

' shtGen show all
  With shtGen.ListObjects("Tableau12")
        .Range.AutoFilter Field:=3
        .Range.AutoFilter Field:=14
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=Range("Tableau12[[#All],[Date création]]"), SortOn:= _
        xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
  End With

' Clear former export
  If shtGen.AutoFilterMode Then shtGen.AutoFilterMode = False
  lr = shtGen.Range("C" & Rows.Count).End(3).Row

  With shtTotal.Range("A16:P" & Rows.Count)
    .UnMerge
    .ClearContents
    .ClearFormats
  End With

  cDir = shtTotal.Range("B6").Value
  cType = shtTotal.Range("B7").Value

  With shtGen.Range("A15:P" & lr)
    If cDir <> "" Then .AutoFilter 3, cDir Else .AutoFilter 3, "*"
    If cType <> "" Then .AutoFilter 14, cType Else .AutoFilter 14, "*"
  End With

  If shtGen.Range("C" & Rows.Count).End(3).Row > 16 Then
    shtGen.AutoFilter.Range.Offset(1).Copy shtTotal.Range("A16")
    If shtGen.AutoFilterMode Then shtGen.AutoFilterMode = False
  End If

' shtGen show all + chronological order
  With shtGen.ListObjects("Tableau12")
        .Range.AutoFilter Field:=3
        .Range.AutoFilter Field:=14
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=Range("Tableau12[[#All],[Date création]]"), SortOn:= _
        xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
  End With

  With shtGen.ListObjects("Tableau12").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
  End With

' Msg if no result
  lrt = shtTotal.Range("A" & Rows.Count - 1).End(xlUp).Row
    With shtTotal.Range("A16:P" & lrt)
        If Application.WorksheetFunction _
        .Sum(shtTotal.Range("A16:P" & lrt)) = 0 Then
            MsgBox "Aucun résultat trouvé"
        Else
        End If
    End With

' =================
' Part two: Offset & Format
  Dim rngT As Range
  Dim rowT As Long
  Dim iP As Range
  Dim rPair As Long

  Set rngT = shtTotal.Range("A16:P" & lrt)
  
' Format cells
  shtTotal.Range("A16:P" & lrt + 1).RowHeight = 12.75

  With shtTotal.Range("H16:K" & lrt + 1)
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Borders(xlEdgeTop).Weight = xlThin
            .Borders(xlEdgeLeft).Weight = xlThin
            .Borders(xlEdgeRight).Weight = xlThin
            .Borders(xlEdgeBottom).Weight = xlThin
  End With

' Add blank row X+1
  For rowT = rngT.Rows.Count To 2 Step -1
    With rngT.Rows(rowT)
        .EntireRow.Insert
         rngT.Rows(rowT).Columns("B:G").Merge
         rngT.Rows(rowT).Columns("B:G").Font.Bold = True
         rngT.Rows(rowT).RowHeight = 20
        .VerticalAlignment = xlCenter
    End With
  Next rowT

' Merge blank row below last row
  With shtTotal.Range("A" & Rows.Count).End(xlUp).Offset(1) _
    .Columns("B:G")
        .Merge
        .VerticalAlignment = xlCenter
        .RowHeight = 20
        .Font.Bold = True
  End With

' Put P to next row
  For Each iP In shtTotal.Range("P16:P300")
    If iP.Value <> "" Then
        iP.Offset(1, -14).Value = iP.Value
    End If
  Next iP

' No workerino ;:(
'  For Each iP In shtTotal.Range("A16:A" & lrt)
'    If IsEmpty(iP.Value) = False Then
'        shtTotal.Range(Rows(iP), Rows(iP.Offset(1, 0))).Merge
'    End If
'  Next iP

  shtTotal.Columns("M").Delete
  shtTotal.Columns("O:P").Delete
  shtGen.Range("N15").Copy shtTotal.Range("M15")

For rPair = rngT.Rows.Count + 1 To 2 Step -2
    With rngT.Rows(rPair).Columns("A:M")
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Borders(xlEdgeLeft).Weight = xlMedium
            .Borders(xlEdgeRight).Weight = xlMedium
            .Borders(xlEdgeBottom).Weight = xlMedium
    End With
Next rPair
For rPair = rngT.Rows.Count + 1 To 2 Step -4
    With rngT.Rows(rPair).Columns("A:M").Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.149998474074526
        .PatternTintAndShade = 0
    End With
    With rngT.Rows(rPair - 1).Columns("A:M").Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.149998474074526
        .PatternTintAndShade = 0
    End With
Next rPair

    With rngT.Range("M15:M" & lrt + 1)
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlEdgeRight).Weight = xlMedium
    End With

End Sub

 

[YourBroLucas]

Here's a sample:
(On a sidenote, in the 'no workerino' section, I'd like to merge cells like H16 & H17 to be centered. I'll test your solution right away.)

File test MeF.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M
6	Department	DICOM
7	Type	Audiovisuel							create graph dynamically with progression
8			ajout prestataires
9	Date budget		n° BC	Champs de recherche
10			Fiche com
11	insight1
12	insight2
13	insight3
14
15	N°	Date création	Direction	Bureau	Prestataire	Fiche com	BDC/EJ	AE antérieurs	AE	CP	Restant dû	SF	Type
16	8	08/01/2022	DICOM	BAVP	Can't be disclosed	9135460	1405711456	12,00 €		2,00 €	- 2,00 €		Audiovisuel
17		Some description of the transaction
18	9	09/01/2022	DICOM	BAVP	Can't be disclosed	9135290		12,00 €		2,00 €	- 2,00 €		Audiovisuel
19		xxxx
20	13	13/01/2022	DICOM	BAVP	Can't be disclosed	9191244	1405723355		1,00 €	2,00 €	- 1,00 €		Audiovisuel
21		xxxx
RECAP_TOTAL

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
K16:K68	Cell Value	=0	text	NO
I69,K16:K68	Cell Value	<0	text	NO
K15	Cell Value	=0	text	NO
K15	Cell Value	<0	text	NO

Cells with Data Validation
Cell	Allow	Criteria
B6	List	=Variables!$A$2:$A$6
B7	List	=Variables!$C$2:$C$19

 

[YourBroLucas]

So I tried your former solution again and it indeed does not apply any background color for some obscure reason.

The conditional format, though, does appear in the 'Manage rules' list with the right setup and proper range.

I've carefully read the code to try and locate the eventual error, but there are none. Could it, perhaps, be caused by the fact that shtGen (the source of shtTotal's data) is a table?

Roses are red,
Violets are cool,
May the VBA gods,
Be merciful.