Macro to refine data displayed based on criteria

vee_vee8

New Member
Joined
Feb 6, 2020
Messages
9
Office Version
  1. 2016
Platform
  1. Windows
Hello,

I was hoping to get some assistance to see if something was possible with VBA code. I have a workbook where I need to refine the data display based on the values to create a list of items for checking. Normally this workbook would have 100+ rows of data but I've just taken a copy of a small test sample of data just for this.

I was hoping to find out if there was a way to display data

For 'Type A' in Column A - display any Duration values in Column D greater than 20
For 'Type B' in Column A - display any Duration values in Column D greater than 40
For 'Type C' in Column A - display any Duration values in Column D less than 98
For 'Type D' in Column A - display any Duration values in Column D less than 196

I'm really not that great with VBA so I'm just feeling a bit lost with it.

Thanks!

Sample Data.xlsx
ABCD
1TypeBegin DateEnd DateDuration
2Type B1/01/202230/01/202230
3Type B5/01/202215/02/202242
4Type A9/01/202216/01/20228
5Type A10/01/20224/02/202226
6Type A10/01/202230/01/202221
7Type A12/01/20225/02/202225
8Type B12/01/20225/03/202253
9Type D16/01/202225/07/2022191
10Type C20/01/20221/04/202272
11Type B3/02/202219/02/202217
12Type A9/02/202219/02/202211
13Type C15/02/202223/05/202298
14Type C16/02/202224/05/202298
15Type D19/02/20222/09/2022196
16Type D21/02/20222/09/2022194
17Type D21/02/20221/07/2022131
18Type D21/02/20224/09/2022196
19Type B1/03/20221/05/202262
20Type C25/03/202228/06/202296
21Type C1/04/20221/07/202292
Sheet1
Cell Formulas
RangeFormula
D2:D21D2=C2-B2+1
 

Excel Facts

Is there a shortcut key for strikethrough?
Ctrl+S is used for Save. Ctrl+5 is used for Strikethrough. Why Ctrl+5? When you use hashmarks to count |||| is 4, strike through to mean 5.
Do you want to sort by Type then by Duration?
Type A 20
Type A 30
Type B 41
Type B 50
...

Or just in orginal order, one by one?
 
Upvote 0
Do you want to sort by Type then by Duration?
Type A 20
Type A 30
Type B 41
Type B 50
...

Or just in orginal order, one by one?
I think if it was just in the original order that would work, unless sorting it first made it simpler? I'm really just trying to find a way to exclude data that doesn't need to be looked at
 
Upvote 0
OK. this code sort by type. Results is pasted from cell F2
VBA Code:
Option Explicit
Sub arrange()
Dim Lr&, i&, k&, cell As Range, typ, dur, arr()
typ = Array("Type A", "Type B", "Type C", "Type D") ' list of type
dur = Array(20, 40, 98, 196) ' relevant value of type
Lr = Cells(Rows.Count, "A").End(xlUp).Row
ReDim arr(1 To Lr, 1 To 4)
For i = 0 To UBound(typ)
    For Each cell In Range("A2:A" & Lr)
        If cell = typ(i) And IIf(i < 2, cell.Offset(0, 3) > dur(i), cell.Offset(0, 3) < dur(i)) Then
            k = k + 1
            arr(k, 1) = cell.Value
            arr(k, 2) = cell.Offset(0, 1).Value
            arr(k, 3) = cell.Offset(0, 2).Value
            arr(k, 4) = cell.Offset(0, 3).Value
        End If
    Next
Next
Range("F2").Resize(k, 4).Value = arr
End Sub
Book1
ABCDEFGHI
1TypeBegin DateEnd DateDurationTypeBegin DateEnd DateDuration
2Type B01/01/202230/01/202230Type A10/01/202204/02/202226
3Type B05/01/202215/02/202242Type A10/01/202230/01/202221
4Type A09/01/202216/01/20228Type A12/01/202205/02/202225
5Type A10/01/202204/02/202226Type B05/01/202215/02/202242
6Type A10/01/202230/01/202221Type B12/01/202205/03/202253
7Type A12/01/202205/02/202225Type B01/03/202201/05/202262
8Type B12/01/202205/03/202253Type C20/01/202201/04/202272
9Type D16/01/202225/07/2022191Type C25/03/202228/06/202296
10Type C20/01/202201/04/202272Type C01/04/202201/07/202292
11Type B03/02/202219/02/202217Type D16/01/202225/07/2022191
12Type A09/02/202219/02/202211Type D21/02/202202/09/2022194
13Type C15/02/202223/05/202298Type D21/02/202201/07/2022131
14Type C16/02/202224/05/202298
15Type D19/02/202202/09/2022196
16Type D21/02/202202/09/2022194
17Type D21/02/202201/07/2022131
18Type D21/02/202204/09/2022196
19Type B01/03/202201/05/202262
20Type C25/03/202228/06/202296
21Type C01/04/202201/07/202292
Sheet2
Cell Formulas
RangeFormula
D2:D21D2=C2-B2+1
 
Upvote 0
Solution
OK. this code sort by type. Results is pasted from cell F2
VBA Code:
Option Explicit
Sub arrange()
Dim Lr&, i&, k&, cell As Range, typ, dur, arr()
typ = Array("Type A", "Type B", "Type C", "Type D") ' list of type
dur = Array(20, 40, 98, 196) ' relevant value of type
Lr = Cells(Rows.Count, "A").End(xlUp).Row
ReDim arr(1 To Lr, 1 To 4)
For i = 0 To UBound(typ)
    For Each cell In Range("A2:A" & Lr)
        If cell = typ(i) And IIf(i < 2, cell.Offset(0, 3) > dur(i), cell.Offset(0, 3) < dur(i)) Then
            k = k + 1
            arr(k, 1) = cell.Value
            arr(k, 2) = cell.Offset(0, 1).Value
            arr(k, 3) = cell.Offset(0, 2).Value
            arr(k, 4) = cell.Offset(0, 3).Value
        End If
    Next
Next
Range("F2").Resize(k, 4).Value = arr
End Sub
Book1
ABCDEFGHI
1TypeBegin DateEnd DateDurationTypeBegin DateEnd DateDuration
2Type B01/01/202230/01/202230Type A10/01/202204/02/202226
3Type B05/01/202215/02/202242Type A10/01/202230/01/202221
4Type A09/01/202216/01/20228Type A12/01/202205/02/202225
5Type A10/01/202204/02/202226Type B05/01/202215/02/202242
6Type A10/01/202230/01/202221Type B12/01/202205/03/202253
7Type A12/01/202205/02/202225Type B01/03/202201/05/202262
8Type B12/01/202205/03/202253Type C20/01/202201/04/202272
9Type D16/01/202225/07/2022191Type C25/03/202228/06/202296
10Type C20/01/202201/04/202272Type C01/04/202201/07/202292
11Type B03/02/202219/02/202217Type D16/01/202225/07/2022191
12Type A09/02/202219/02/202211Type D21/02/202202/09/2022194
13Type C15/02/202223/05/202298Type D21/02/202201/07/2022131
14Type C16/02/202224/05/202298
15Type D19/02/202202/09/2022196
16Type D21/02/202202/09/2022194
17Type D21/02/202201/07/2022131
18Type D21/02/202204/09/2022196
19Type B01/03/202201/05/202262
20Type C25/03/202228/06/202296
21Type C01/04/202201/07/202292
Sheet2
Cell Formulas
RangeFormula
D2:D21D2=C2-B2+1
That's amazing, Thank you so much!!
 
Upvote 0
OK. this code sort by type. Results is pasted from cell F2
VBA Code:
Option Explicit
Sub arrange()
Dim Lr&, i&, k&, cell As Range, typ, dur, arr()
typ = Array("Type A", "Type B", "Type C", "Type D") ' list of type
dur = Array(20, 40, 98, 196) ' relevant value of type
Lr = Cells(Rows.Count, "A").End(xlUp).Row
ReDim arr(1 To Lr, 1 To 4)
For i = 0 To UBound(typ)
    For Each cell In Range("A2:A" & Lr)
        If cell = typ(i) And IIf(i < 2, cell.Offset(0, 3) > dur(i), cell.Offset(0, 3) < dur(i)) Then
            k = k + 1
            arr(k, 1) = cell.Value
            arr(k, 2) = cell.Offset(0, 1).Value
            arr(k, 3) = cell.Offset(0, 2).Value
            arr(k, 4) = cell.Offset(0, 3).Value
        End If
    Next
Next
Range("F2").Resize(k, 4).Value = arr
End Sub
Book1
ABCDEFGHI
1TypeBegin DateEnd DateDurationTypeBegin DateEnd DateDuration
2Type B01/01/202230/01/202230Type A10/01/202204/02/202226
3Type B05/01/202215/02/202242Type A10/01/202230/01/202221
4Type A09/01/202216/01/20228Type A12/01/202205/02/202225
5Type A10/01/202204/02/202226Type B05/01/202215/02/202242
6Type A10/01/202230/01/202221Type B12/01/202205/03/202253
7Type A12/01/202205/02/202225Type B01/03/202201/05/202262
8Type B12/01/202205/03/202253Type C20/01/202201/04/202272
9Type D16/01/202225/07/2022191Type C25/03/202228/06/202296
10Type C20/01/202201/04/202272Type C01/04/202201/07/202292
11Type B03/02/202219/02/202217Type D16/01/202225/07/2022191
12Type A09/02/202219/02/202211Type D21/02/202202/09/2022194
13Type C15/02/202223/05/202298Type D21/02/202201/07/2022131
14Type C16/02/202224/05/202298
15Type D19/02/202202/09/2022196
16Type D21/02/202202/09/2022194
17Type D21/02/202201/07/2022131
18Type D21/02/202204/09/2022196
19Type B01/03/202201/05/202262
20Type C25/03/202228/06/202296
21Type C01/04/202201/07/202292
Sheet2
Cell Formulas
RangeFormula
D2:D21D2=C2-B2+1
Really sorry to bother you with this again, but I had a question that I was hoping you could help with again? If new columns of data got added in Column A and Column F so the Type and Duration columns got moved across, how could the vba be modified?
 

Attachments

  • Screenshot Sample Data.png
    Screenshot Sample Data.png
    34.2 KB · Views: 8
Upvote 0
VBA Code:
Option Explicit
Sub arrange()
Dim Lr&, i&, k&, cell As Range, typ, dur, arr()
typ = Array("Type A", "Type B", "Type C", "Type D") ' list of type
dur = Array(20, 40, 98, 196) ' relevant value of type
Lr = Cells(Rows.Count, "B").End(xlUp).Row ' Adjust "A" to "B" (column with type)
ReDim arr(1 To Lr, 1 To 4)
For i = 0 To UBound(typ)
    For Each cell In Range("B2:B" & Lr) ' change A to B
        If cell = typ(i) And IIf(i < 2, cell.Offset(0, 3) > dur(i), cell.Offset(0, 3) < dur(i)) Then
            k = k + 1
            arr(k, 1) = cell.Value
            arr(k, 2) = cell.Offset(0, 1).Value
            arr(k, 3) = cell.Offset(0, 2).Value
            arr(k, 4) = cell.Offset(0, 3).Value
        End If
    Next
Next
Range("G2").Resize(k, 4).Value = arr ' paste to column G
End Sub
 
Upvote 0

Forum statistics

Threads
1,216,095
Messages
6,128,790
Members
449,468
Latest member
AGreen17

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top