Stuck even starting to write a macro

[tcfreer]

Hi All

Ok so I've asked for help a few times on here, and in some cases found the answer from here after being pointed in the right direction.

I am after creating a macro / writing vba code to do the following check.

I have the following column headers on a sheet

Item Item Description UOM Location Batch Code Expiry Date (If Applicable) Qty <colgroup><col><col><col><col><col><col><col></colgroup><tbody> </tbody> <strike></strike>

<tbody>
</tbody>

Now the first 3 rows are generated fine - there is no need to check these as they come from a main database source.
the location is a variable - however again it doesn't need checking
The Last Column QTY is a count as you may of guessed - and this will change row to row so its fine

The ones that need checking at Batch Code and Expiry Date (If Applicable)

I need to create a check code to go through the whole list and find were we have the same batch code and differing expiry dates

For example a

Batch code = 12345
Expiry dates = 01/02/2016 and 02/02/2016

Each batch should have the same date.

I then want to pull out / format in a colour the rows that need checking because of these differences.

I was going to do a countifs were a batch code, and date match - how ever because of the differing locations we could have different locations with the same batch and date.

I was also going to count how many times a batch code+date appear, however again, we could only have 1 batch of this product

Can something be coded to handle this or should I do series of count columns with a final column that if they all equeal the same number then its right, if not its false?

 

[RCBricker]

This will check the batch numbers and see if the dates match the first occurrence in the list.

There is a sheet name variable that you need to change to reflect your sheet name

Sub tcfreer()
Dim wb As Workbook
Dim ws As Worksheet
Dim rngBAT As Range, cellBAT As Range, rng As Range
Dim lngROW As Long, lngCOL As Long
Dim intBAT As Integer
Dim arrBAT() As Variant, varI As Variant
Dim dEXP As Date
    Set wb = ThisWorkbook
    Set ws = wb.Sheets("tcfreer") 'change to your sheet name
    
    With ws
        lngROW = ws.Range("E" & ws.Rows.Count).End(xlUp).Row
        lngCOL = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
        Set rngBAT = ws.Range(ws.Cells(1, 1), ws.Cells(1, lngCOL))
        intBAT = rngBAT.Find("Batch Code").Column
        Set rngBAT = ws.Range(ws.Cells(1, intBAT), ws.Cells(lngROW, intBAT))
        rngBAT.Copy
        ws.Cells(1, lngCOL + 5).PasteSpecial xlPasteAll
        Set rng = ws.Range(ws.Cells(1, lngCOL + 5), ws.Cells(lngROW, lngCOL + 5))
        Application.CutCopyMode = False
        rng.RemoveDuplicates Columns:=1, Header:=xlYes
        ws.Cells(1, lngCOL + 5).Delete shift:=xlUp
        lngROW = ws.Cells(ws.Rows.Count, lngCOL + 5).End(xlUp).Row
        Set rng = ws.Range(ws.Cells(1, lngCOL + 5), ws.Cells(lngROW, lngCOL + 5))
        arrBAT = rng
        rng.Delete
        For Each varI In arrBAT
            dEXP = 0
            For Each cellBAT In rngBAT
                If cellBAT = varI Then
                    If dEXP = 0 Then
                        dEXP = cellBAT.Offset(, 1).Value
                    Else
                        If dEXP <> cellBAT.Offset(, 1).Value Then
                            ws.Range(ws.Cells(cellBAT.Row, 1), _
                                ws.Cells(cellBAT.Row, lngCOL)).EntireRow _
                                .Interior.Color = 652
                        End If
                    End If
                End If
            Next cellBAT
        Next varI
    End With
End Sub

 

[tcfreer]

@RCBricker

Brilliant - works on my test data, but it has highlighted some over area's I need to handle - spaces in the text were there shouldn't be for example,

I think what I'll do as routine to run first, that clears any spaces from the row that it could have them in - then run this routine

That should handle most things I believe?

 

[tcfreer]

@RCbricker

Bad news, when I get the trim working to remove the differences in the Batch code format it gives a error message on the arrBAT = rng

Its a Run-time error '13':Type Mismatch

Any ideas?

 

[RCBricker]

post your code with the trim command in it

 

[tcfreer]

@RCBricker

I didn't use any code - I just over typed without the code on this occasion - I've not got as far as putting in a trim code yet. I wanted to make sure that it would still work as intended

 

[RCBricker]

ok I added code to perform trim on the values before they are entered into the array.

Sub tcfreer()
Dim wb As Workbook
Dim ws As Worksheet
Dim rngBAT As Range, cellBAT As Range, rng As Range
Dim lngROW As Long, lngCOL As Long
Dim intBAT As Integer
Dim arrBAT() As Variant, varI As Variant
Dim dEXP As Date
    Set wb = ThisWorkbook
    Set ws = wb.Sheets("tcfreer") 'change to your sheet name
    
    With ws
        lngROW = ws.Range("E" & ws.Rows.Count).End(xlUp).Row
        lngCOL = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
        Set rngBAT = ws.Range(ws.Cells(1, 1), ws.Cells(1, lngCOL))
        intBAT = rngBAT.Find("Batch Code").Column
        Set rngBAT = ws.Range(ws.Cells(1, intBAT), ws.Cells(lngROW, intBAT))
        rngBAT.Copy
        ws.Cells(1, lngCOL + 5).PasteSpecial xlPasteAll
        Set rng = ws.Range(ws.Cells(1, lngCOL + 5), ws.Cells(lngROW, lngCOL + 5))
        For Each cellBAT In rng
            cellBAT.Offset(, 1).Value = LTrim(cellBAT.Value)
        Next cellBAT
        rng.Delete shift:=xlUp
        Set rng = ws.Range(ws.Cells(1, lngCOL + 6), ws.Cells(lngROW, lngCOL + 6))
        Application.CutCopyMode = False
        rng.RemoveDuplicates Columns:=1, Header:=xlYes
        ws.Cells(1, lngCOL + 6).Delete shift:=xlUp
        lngROW = ws.Cells(ws.Rows.Count, lngCOL + 6).End(xlUp).Row
        Set rng = ws.Range(ws.Cells(1, lngCOL + 6), ws.Cells(lngROW, lngCOL + 6))
        arrBAT = rng
        rng.Delete shift:=xlUp
        For Each varI In arrBAT
            dEXP = 0
            For Each cellBAT In rngBAT
                If cellBAT = varI Then
                    If dEXP = 0 Then
                        dEXP = cellBAT.Offset(, 1).Value
                    Else
                        If dEXP <> cellBAT.Offset(, 1).Value Then
                            ws.Range(ws.Cells(cellBAT.Row, 1), _
                                ws.Cells(cellBAT.Row, lngCOL)).EntireRow _
                                .Interior.Color = 652
                        End If
                    End If
                End If
            Next cellBAT
        Next varI
    End With
End Sub

 

[tcfreer]

@RCBricker

Just tried it - I get the same mismatch error, but now its in this line - dEXP = cellBAT.Offset(, 1).Value

 

[tcfreer]

Found the error - the date has been input as 35/15/2017

I think this is something I need to handle on the actual input form so that's a separate issue

 

[RCBricker]

yeah that would be a data error issue not a code issue. You could use data validation to control the input of the date.

so does the code work as you expect (other than date errors)?