"For" but only visible cells issue

[KasperC]

Hello,

I'm trying to remove and change certain values from a dataset which has been filtered.
As the size of the data-set is quite big, I want to narrow down the FOR range in order to make the vba more efficient.

I found some threads suggesting the "For Each" and with a range In specialcells "type visible" - but I seem to have issiues to get this to work.
In addition, As I'm deleting and moving up rows from the data-set, I'm afraid that the code will skip the just moved-up row if i leave the code "as is".

This is what my code looked like, but as it checks every i, its very inefficient - even though it does work perfectly.

        For i = LastRow To 2 Step -1
            If Left(ws.Cells(i, 1), 1) = "2" Then
                    If Left(ws.Cells(i, 1), 4) = "2000" And Len(ws.Cells(i, 1)) > 4 _
                        Then
                            ws.Cells(i, 1).EntireRow.Delete Shift:=xlUp
                        End If
                    If Left(ws.Cells(i, 1), 2) = "23" And Len(ws.Cells(i, 1)) > 4 And Len(ws.Cells(i, 1)) < 13 _
                        Then
                            ws2.Range("A2").Value = ws.Cells(i, 1).Value & "0000"
                            ws.Cells(i, 1).Value = ws2.Range("H2").Value
                        End If
                    If Left(ws.Cells(i, 1), 2) = "20" And Len(ws.Cells(i, 1)) > 4 And Len(ws.Cells(i, 1)) < 13 _
                        Then
                            ws2.Range("A2").Value = ws.Cells(i, 1).Value & "0000"
                            ws.Cells(i, 1).Value = ws2.Range("H2").Value
                        End If
                End If
        Next i

I suppose something like this is what I need, allthough I'm not able to make it work.. Does anyone have any ideas?

        Dim i As Range
        For Each i In ws.Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible)
            If Left(i, 1) = "2" And Not Left(i, 2) = "29" Then
                    If Left(i, 4) = "2000" And Len(i) > 4 _
                        Then
                            i.EntireRow.Delete Shift:=xlUp
                        End If
                    If Left(i, 2) = "23" And Len(i.Value) > 4 And Len(i.Value) < 13 _
                        Then
                            ws2.Range("A2").Value = i.Value & "0000"
                            i.Value = ws2.Range("H2").Value
                        End If
                    If Left(i, 2) = "20" And Len(i.Value) > 4 And Len(i.Value) < 13 _
                        Then
                            ws2.Range("A2").Value = i.Value & "0000"
                            i.Value = ws2.Range("H2").Value
                        End If
                End If
        Next i

Thank you for your time.

Sincerely
Kasper C

 

[KasperC]

I put a date into cell L1 in the format you described in post #27:

and the filter worked fine for me when I used the code in post #28. As such, there's nothing more I can do with regard to the filter issue as I can't reproduce the problem at my end.

As far as the rest of post #29 goes - this is the first time you've mentioned replacing values with J anything (and the first mention of 148) so I don't know if these are additional conditions you're now introducing, and if so, please feel free to add them to your code in whatever method you choose. Personally I would use a Select Case approach, but if you'd rather go with the alternative method you're suggesting in post #29 - be my guest

I feel I've gone as far as I can go with assisting you with this thread Kasper, and I'm sorry I couldn't provide a solution that meets all your needs. I'm stepping out of this now, and I hope that others here on the platform can assist you to a final resolution of your desired outcome. Best wishes & good luck

Im sure I'll manage to figure out how to solve this issiue. Thank you so much for your help, definently found a much faster way to work through the data.

I would go with the Select Case approach, but I need to make the code work with more "cases" in the future, when I'm no longer working on the project.. So I think the arr-notepad will work out for me.

Again - thank you so much!

 

[KasperC]

Last try tonight before I switch the laptop off. Try this on a copy of your workbook:

Option Explicit
Sub KasperC_V1()
    Dim t As Double: t = Timer
    Application.Calculation = xlManual
    Application.ScreenUpdating = False
   
    'Stage 1 - delete superfluous rows from sheet 1
    Dim ws As Worksheet
    Set ws = Worksheets("Sheet1")       '<~~ *** Change sheet name as required ***
    Dim LRow As Long, i As Long
    Dim a, b, c
    c = Array(0, 1, 4, 9)
    LRow = ws.Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
    a = Range(ws.Cells(2, 1), ws.Cells(LRow, 1)).Resize(, 2)
    ReDim b(1 To UBound(a, 1), 1 To 1)
  
    For i = 1 To UBound(a)
        If Left(a(i, 1), 4) = "2000" And Len(a(i, 1)) > 4 Then b(i, 1) = 1
        If Not IsError(Application.Match(a(i, 2), c, 0)) Then b(i, 1) = 1
    Next i
  
    ws.Cells(2, 11).Resize(UBound(a)) = b
    i = WorksheetFunction.Sum(ws.Columns(11))
    If i > 0 Then
        ws.Range(ws.Cells(2, 1), ws.Cells(LRow, 11)).Sort Key1:=ws.Cells(2, 11), _
        order1:=xlAscending, Header:=xlNo
        ws.Cells(2, 11).Resize(i).EntireRow.Delete
    End If
    Set a = Nothing
    Set b = Nothing
   
    'Stage 2 - format values starting with 20 or 23 on sheet 1
    Dim ws2 As Worksheet
    Set ws2 = Worksheets("Sheet2")      '<~~ *** Change sheet name as required ***
   
    a = ws.Range("A2", ws.Cells(Rows.Count, "A").End(xlUp))
    ReDim b(1 To UBound(a, 1), 1 To 1)
    Dim s As String
    For i = 1 To UBound(a)
        If Len(a(i, 1)) <= 12 And (Left(a(i, 1), 2) = "20" Or Left(a(i, 1), 2) = "23") Then
            ws2.Range("A2").Value = a(i, 1) & "0000"
            s = CStr("'0" & ws2.Range("A2") & ws2.Range("G2"))
            b(i, 1) = s
        Else
            b(i, 1) = a(i, 1)
        End If
    Next i
    ws.Range("A2").Resize(UBound(b)).Value = b
    ws.Range("A:A").NumberFormat = "@"
    Set a = Nothing
    Set b = Nothing
   
    'Stage 3 - format column B in sheet 1 according to criteria
    a = ws.Range("B2", ws.Cells(Rows.Count, "F").End(xlUp))
    ReDim b(1 To UBound(a, 1), 1 To 1)
   
    For i = 1 To UBound(a)
        s = a(i, 1) & "|" & a(i, 5)
        Select Case s
            Case "3|133"
                b(i, 1) = "S3"
            Case "3|147"
                b(i, 1) = "S3"
            Case "34|342"
                b(i, 1) = "SD"
            Case Else
                b(i, 1) = a(i, 1)
        End Select
    Next i
    ws.Range("B2").Resize(UBound(b)).Value = b
   
    'Stage 4 - copy to sheet 3 if date matches L1
    Dim DtFltr As Long, ws3 As Worksheet
    Set ws3 = Worksheets("Sheet3")          '<~~ *** Change sheet name as required ***
    DtFltr = ws.Range("L1").Value
   
    With ws.Range("A1").CurrentRegion
        .AutoFilter 3, Format(DtFltr, "d/mm/yyyy")
        If ws.Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
            .Offset(1).Resize(.Rows.Count - 1, 4).Copy ws3.Range("E2")
        End If
        .AutoFilter
    End With
   
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
    MsgBox Timer - t & " seconds"
End Sub

Could I ask you one thing regarding your code?
I've implemented your code into mine and it runs so much faster now - also figured out the filter issiue.

Only thing I'm struggeling with is the Array in pt. 1 of the code, where you declare c = Array(0, 1, 4, 9).
Here I want to retrieve the numbers from a notepad doc - but I cant figure out how to make it work with your code - worked just fine in the comment i made further up..

        Dim FSO As Object, MyFile As Object
        Dim FileName As String, Arr As Variant
        Dim qn As String
       
        FileName = "C:\Users\Username\OneDrive - folder\folder1\folder2\folder3\textfile.txt"
        Set FSO = CreateObject("Scripting.FileSystemObject")
        Set MyFile = FSO.OpenTextFile(FileName, 1)
        Arr = Split(MyFile.ReadAll, vbNewLine)
       
        Dim SV() As String
        SV = Split(Arr(0), " ")

Is there any way I can make your match function look for the values in "SV"? (Arr(0) =0 1 4 9)

 

[kevin9999]

It looks like that array (c) was intended to be used at some point, but I can't see where it is actually referenced in the final code I proposed? Might be one of those 'legacy' lines that I never got around to cleaning up. I've had no experience referencing notepad docs in the manner you're describing, so I'm not much help there I'm afraid. Sorry.

 

[KasperC]

It looks like that array (c) was intended to be used at some point, but I can't see where it is actually referenced in the final code I proposed? Might be one of those 'legacy' lines that I never got around to cleaning up. I've had no experience referencing notepad docs in the manner you're describing, so I'm not much help there I'm afraid. Sorry.

I figured it out! Thank you so much for the help - its so much quicker and honestly better now. - really apprechiate you taking the time.

For some reason I needed to match a string value rather than the range itself - so by just setting sn = a(i, 2) it worked perfectly!
(I moved the filter to an earlier stage and worked that part out that way)

Private Sub That_works()
    Dim ws As Worksheet
    Dim wb As Workbook
    Dim wbn As Workbook
    Dim nws As Worksheet
    Dim adato As String
    Dim LastRow As Long
    
    Set wb = Excel.Workbooks("Workbook.xlsm")
    Set ws = wb.Worksheets("Sheet1")
    Set wbn = Excel.Workbooks("Workbook2.xlsx")
    Set nws = wbn.Worksheets("Sheet1")
    LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    adato = ws.Range("L1").Value
    
        Dim FSO1 As Object, MyFile1 As Object
        Dim FN1 As String, Arr1 As Variant
        
        Dim FSO2 As Object, MyFile2 As Object
        Dim FN2 As String, Arr2 As Variant
    
        FN1 = "C:\Users\Username\OneDrive - folder\folder1\folder2\folder3\textfile.txt"
        Set FSO1 = CreateObject("Scripting.FileSystemObject")
        Set MyFile1 = FSO1.OpenTextFile(FN1, 1)
        Arr1 = Split(MyFile1.ReadAll, vbNewLine)
        
        FN2 = "C:\Users\Username\OneDrive - folder\folder1\folder2\folder3\textfile2.txt"
        Set FSO2 = CreateObject("Scripting.FileSystemObject")
        Set MyFile2 = FSO2.OpenTextFile(FN2, 1)
        Arr2 = Split(MyFile2.ReadAll, vbNewLine)
    
    Dim LRow As Long, i As Long
    Dim a, b, c
    Dim qn As String
    Dim sn As String
    Dim M As String
    Dim M1 As String
    Dim M2 As String
    
    LRow = ws.Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
    a = Range(ws.Cells(2, 1), ws.Cells(LRow, 1)).Resize(, 2)
    ReDim b(1 To UBound(a, 1), 1 To 1)
    ReDim c(1 To UBound(a, 1), 1 To 1)
    
    For i = 1 To UBound(a)
        sn = a(i, 2)
        qn = a(i, 2) & "/" & ws.Cells(i, 6)
        
        If Left(a(i, 1), 4) = "2000" And Len(a(i, 1)) > 4 Then
                b(i, 1) = 1
                Next i
            End If
            
        If Not IsError(Application.match(sn, Arr1, 0)) Then
                b(i, 1) = 1
                Next i
            End If
            
        If IsError(Application.match(qn, Arr2, 0)) Then
                b(i, 1) = 1
            Else
                c(i, 1) = Arr2(Application.WorksheetFunction.match(qn, Arr2, 0))
            End If
            
        If Len(a(i, 1)) <= 12 And (Left(a(i, 1), 2) = "20" Or Left(a(i, 1), 2) = "23") Then
            M = ws.Cells(i, 1) & "0000"
            M1 = 3 * ((M - (Int(M / 10) * 10)) + ((M - (Int(M / 1000) * 1000)) - (M - (Int(M / 100) * 100))) / 100 + ((M - (Int(M / 100000) * 100000)) - (M - (Int(M / 10000) * 10000))) / 10000 + ((M - (Int(M / 10000000) * 10000000)) - (M - (Int(M / 1000000) * 1000000))) / 1000000 + ((M - (Int(M / 1000000000) * 1000000000)) - (M - (Int(M / 100000000) * 100000000))) / 100000000 + ((M - (Int(M / 100000000000#) * 100000000000#)) - (M - (Int(M / 10000000000#) * 10000000000#))) / 10000000000#) _
                + (((M - (Int(M / 100) * 100)) - (M - (Int(M / 10) * 10))) / 10 + ((M - (Int(M / 10000) * 10000)) - (M - (Int(M / 1000) * 1000))) / 1000 + ((M - (Int(M / 1000000) * 1000000)) - (M - (Int(M / 100000) * 100000))) / 100000 + ((M - (Int(M / 100000000) * 100000000)) - (M - (Int(M / 10000000) * 10000000))) / 10000000 + ((M - (Int(M / 10000000000#) * 10000000000#)) - (M - (Int(M / 1000000000) * 1000000000))) / 1000000000 + ((M - (Int(M / 1000000000000#) * 1000000000000#)) - (M - (Int(M / 100000000000#) * 100000000000#))) / 100000000000#)
            M2 = M1 + 10 - (M1 - (Int(M1 / 10) * 10)) - M1
            
            If M2 = 10 Then
                ws.Cells(i, 1).Value = "0" & M & "0"
            Else
                ws.Cells(i, 1).Value = "0" & M & M2
            End If
        End If
        
    Next i
    
    ws.Cells(2, 11).Resize(UBound(a)) = b
    ws.Cells(2, 2).Resize(UBound(a)) = c
    i = WorksheetFunction.Sum(ws.Columns(11))
    If i > 0 Then
        ws.Range(ws.Cells(2, 1), ws.Cells(LRow, 11)).Sort Key1:=ws.Cells(2, 11), order1:=xlAscending, Header:=xlNo
        ws.Cells(2, 11).Resize(i).EntireRow.Delete
    End If
    
    
    

End Sub