VBA check length of cell value in a range

[mansoorsak]

Hi
I have a requirement where I need to check the length of cell value in 2 ranges (eg. column A to Last row & column E to Last row) and also detect if a specific range in column is empty in about 60 files in a folder.
length (column a) should be exactly 32 characters long
length (column e) should be exactly 10 characters long


If any cell in these 3 columns doesn't match the above criteria, then it should replace the existing file name with prefix "error"


Considering the volume of data (60 files with 800k rows in each file) any short & simple code that takes shorter time in running the vba macro would be of great help.


Thanks in Advance for the help

 

[mumps]

What is the full path to the folder containing the files? Are they the only files in that folder? What is the file extension (xlsx, xlsm)? What is the name of the sheet you want to check in each file? Does the data you want to check start in row 1? What is the specific range you want to check if it is empty and in which column?

 

[mansoorsak]

The full path to the folder is "C:\Users\Mansoor\Desktop\DRR"
Yes, they are the only files in the folder
The file extension is xlsx
The sheet name varies from file to file however it's the only sheet in the file
Yes, the data start in row 1
The range would be columns Y:AB (entire columns)

 

[mumps]

To clarify:
Does row 1 contain the headers or does it contain data that you want to compare?
To match the criteria, the length (column A) should be exactly 32 characters long, the length (column E) should be exactly 10 characters long and the corresponding cells in columns Y:AB must be blank. For example, cell A2 is 32 characters long, cell E2 is 10 characters long, one or more cells Y2:AB2 are not blank. This example would not be a match. Is this correct? Also, would it be correct to say that the combined length of column A and column B must be exactly 42 characters long?

 

[mansoorsak]

row 1 contains the data (no header)
It should check 3 criteria, the length (column A) should be exactly 32 characters long, the length (column E) should be exactly 10 characters long and the corresponding cells in columns Y:AB must be blank (there shouldn't be any data here). If the data doesn't satisfy any of these 3 criteria then it is an error (something is wrong with the data) hence it should replace the existing file name with prefix "error". For example each cell between a2:a5000 is 32 character long, one of the cells between e2:e5000 is not 10 character long and Y2:ab5000 cells are blank. Here criteria 2 doesnt' match hence there is some issue with the data, in this case it should replace the existing file name with prefix "error"
for your last question, it would good to check the length of each column separately (it would be easier for me to modify the code for any similar type of requirement)

 

[mumps]

OK. Give me a little time to see what I can do.

 

[mumps]

You will need to place this macro in an existing workbook or in a new blank workbook and run it from there. I would strongly recommend that before you run the macro, you create a copy of your folder containing all your 60 files. The macro deletes the old files if a new one with "error" is created. The backup of your folder will ensure that if something goes wrong, you will not lose any files.

Sub CheckCols()
    With Application
        .ScreenUpdating = False
        .Application.Calculation = xlCalculationManual
    End With
    Dim LastRow As Long, srcWB As Workbook, srcRng As Variant, i As Long, fName As String
    Const strPath As String = "C:\Users\Mansoor\Desktop\DRR\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set srcWB = Workbooks.Open(strPath & strExtension)
            fName = srcWB.Name
            LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            srcRng = Range("A1:AB" & LastRow).Resize(, 28).Value
            For i = LBound(srcRng) To UBound(srcRng)
                If Len(srcRng((i), 1)) <> 32 Or Len(srcRng((i), 2)) <> 10 Or Len(srcRng((i), 25)) <> 0 Or Len(srcRng((i), 26)) <> 0 Or Len(srcRng((i), 27)) <> 0 Or Len(srcRng((i), 28)) <> 0 Then
                    srcWB.SaveAs Filename:="C:\Users\Mansoor\Desktop\DRR\error" & fName
                    Kill "C:\Users\Mansoor\Desktop\DRR\" & fName
                    Exit For
                End If
            Next i
            ActiveWorkbook.Close savechanges:=False
        strExtension = Dir
    Loop
    With Application
        .ScreenUpdating = True
        .Application.Calculation = xlCalculationAutomatic
    End With
End Sub

 

[mansoorsak]

Thanks a lot for this code, it's working fine.

Can you help me put one more condition here. In column 2, it should check the character length of only the non blank cells. Example in range B1:B500 there are about 5 blank cells & all the non blank cells length is 10 characters long. In this case it should not save the file name with prefix "error"

 

[mansoorsak]

how to set a range of only non blank cells in column 2

 

[mumps]

Try:

Sub CheckCols()
    With Application
        .ScreenUpdating = False
        .Application.Calculation = xlCalculationManual
    End With
    Dim LastRow As Long, srcWB As Workbook, srcRng As Variant, i As Long, fName As String
    Const strPath As String = "C:\Users\Mansoor\Desktop\DRR\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set srcWB = Workbooks.Open(strPath & strExtension)
            fName = srcWB.Name
            LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            srcRng = Range("A1:AB" & LastRow).Resize(, 28).Value
            For i = LBound(srcRng) To UBound(srcRng)
                If srcRng((i), 2) <> "" Then
                    If Len(srcRng((i), 1)) <> 32 Or Len(srcRng((i), 2)) <> 10 Or Len(srcRng((i), 25)) <> 0 Or Len(srcRng((i), 26)) <> 0 Or Len(srcRng((i), 27)) <> 0 Or Len(srcRng((i), 28)) <> 0 Then
                        srcWB.SaveAs Filename:="C:\Users\Mansoor\Desktop\DRR\error" & fName
                        Kill "C:\Users\Mansoor\Desktop\DRR\" & fName
                        Exit For
                    End If
                End If
            Next i
            ActiveWorkbook.Close savechanges:=False
        strExtension = Dir
    Loop
    With Application
        .ScreenUpdating = True
        .Application.Calculation = xlCalculationAutomatic
    End With
End Sub