"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

 

[mumps]

It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your sheet. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

 

[KasperC]

It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your sheet. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

Thank you for wanting to attempt to solve my issiue.

Link to the document below.
Example sheet – Kopi.xlsm | Powered by Box

I've created a new document with the core elements I need (to de-sensitize).
Wrote a couple of notes in the code to hopefully clearify what I need.

To sum up:

First I need to sort the values by a date which exists in the data-set in "c1".
From this I need to delete rows with a value which starts with "2000", in addition to formatting numbers starting with 20 and 23 under 13 digits. The formatting happenes on another sheet outside the code.

After that I need to change a bunch of values in the B column. Rows with 0, 1, 4 and 9 needs to be deleted, 3 and 8 needs to be changed according to the rules in the code.

After that I copy whats visible and whats left, and paste it into an outpoot wb.

-
As the code lies right now, it works just fine. Problem is that there is a ton of data, and its working through and changing all dates, even though Im just looking for relevant information in one specific date. Therefore, Im wondering if there is a way for this deleting 2000, changing 20/23 numbers, aswell as the B-column changes with visible cells only - in order to speed up the process.
Right now it takes around 11 minutes or so for the code to go through everything.

Again, thank you for your time.

 

[kevin9999]

Any chance of sharing a sample with at least some data in it? 2 blank sheets don't help too much - even just a few rows of data would help

the size of the data-set is quite big

Right now it takes around 11 minutes or so for the code to go through everything

Let's break this down. You've got a very slow method to delete the rows you don't need. If I read your logic correctly, there's no reason why you can't delete all unnecessary rows first, which I understand to be any value in column A of sheet 1 that starts "2000" and is longer than 4 characters, and where column B contains any of the following values: 0, 1, 4, 9. If that's correct so far, try the following on a copy of your workbook. I tested it on a data sample of 100K rows (12 columns) where 50K met the criteria for deletion. It completed in under 2 seconds. If this does the deletion part correctly, share some of your actual data & @mumps or I can look at doing the rest.

Option Explicit
Sub Delete_Demo()
    Dim t As Double: t = Timer
    Application.Calculation = xlManual
    Application.ScreenUpdating = False
   
    Dim ws As Worksheet
    Set ws = Worksheets("Sheet1")
    Dim LRow As Long, LCol As Long, i As Long
    Dim a, b, c
    c = Array(0, 1, 4, 9)
   
    LRow = ws.Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
    LCol = ws.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column + 1
    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, LCol).Resize(UBound(a)) = b
    i = WorksheetFunction.Sum(ws.Columns(LCol))
    If i > 0 Then
        ws.Range(ws.Cells(2, 1), ws.Cells(LRow, LCol)).Sort Key1:=ws.Cells(2, LCol), _
        order1:=xlAscending, Header:=xlNo
        ws.Cells(2, LCol).Resize(i).EntireRow.Delete
    End If
   
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
    MsgBox Timer - t & " seconds"
End Sub

 

[KasperC]

Any chance of sharing a sample with at least some data in it? 2 blank sheets don't help too much - even just a few rows of data would help


Let's break this down. You've got a very slow method to delete the rows you don't need. If I read your logic correctly, there's no reason why you can't delete all unnecessary rows first, which I understand to be any value in column A of sheet 1 that starts "2000" and is longer than 4 characters, and where column B contains any of the following values: 0, 1, 4, 9. If that's correct so far, try the following on a copy of your workbook. I tested it on a data sample of 100K rows (12 columns) where 50K met the criteria for deletion. It completed in under 2 seconds. If this does the deletion part correctly, share some of your actual data & @mumps or I can look at doing the rest.

Option Explicit
Sub Delete_Demo()
    Dim t As Double: t = Timer
    Application.Calculation = xlManual
    Application.ScreenUpdating = False
  
    Dim ws As Worksheet
    Set ws = Worksheets("Sheet1")
    Dim LRow As Long, LCol As Long, i As Long
    Dim a, b, c
    c = Array(0, 1, 4, 9)
  
    LRow = ws.Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
    LCol = ws.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column + 1
    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, LCol).Resize(UBound(a)) = b
    i = WorksheetFunction.Sum(ws.Columns(LCol))
    If i > 0 Then
        ws.Range(ws.Cells(2, 1), ws.Cells(LRow, LCol)).Sort Key1:=ws.Cells(2, LCol), _
        order1:=xlAscending, Header:=xlNo
        ws.Cells(2, LCol).Resize(i).EntireRow.Delete
    End If
  
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
    MsgBox Timer - t & " seconds"
End Sub

I will try this out, but where do I put this "Option Explicit"? My "active" code is built into a button on a form.

But I may have to research a bit further - as I might need to make my code slightly more dynamic.
As per now, I only need to format the case 3 in the B column and 133 or 147 into "S3", 3 and 139/354 into SC and 8 and 133/147 into "S8" - but is it possible to make some kind of array of different "cases" with connected return values if i need to add them in the future - and if the case are not to be found in the array, the row shall be deleted? I guess the perfect scenario would be if i could just list my different cases in a seperate sheet or a notepad or something, where i can just add and remove active "cases".
But I do understand if this is a bit to comprehensive - I probably should be able to figure out how to do it - it just takes time

Hope that was understandeble.

Regards,
Kasper

 

[kevin9999]

No worries Kasper, I look forward to your further deliberations. As a general rule, it's always faster to 'loop' through an array of values than accessing the worksheet. Option Explicit goes above your Sub ... line in your module. It's a best-practice thing (forces you to declare all variables used within the module).

 

[KasperC]

No worries Kasper, I look forward to your further deliberations. As a general rule, it's always faster to 'loop' through an array of values than accessing the worksheet. Option Explicit goes above your Sub ... line in your module. It's a best-practice thing (forces you to declare all variables used within the module).

Thank you for the support

I tried your code, And probably no suprise, but its really fast - just about 5 secconds.

But it seems to be deleting all values under 13 digits long in the A column, though - such as "4036" or "2056468"
In addition, it does not seem to be deleting any rows with the array cases in column B

I'm trying to study your code, but I think my knowledge comes a bit too short trying to problemsolve it.

Further - I'm having trouble finding any good sources on how to build an array with multiple criteria - and applying rules depending if a specific criteria is found or not. Do you have any that you would reccomend?

What I need is that I can add ex.
"3, 133, S3"
"3, 147, S3"
"34, 342, SD"

To a list, excel sheet, or notepad
- then having the vba look through the filtered data-set for these "criteria", where the first value is in column B and the seccond is in column F.
- if it finds a row that fits the criteria, I want it to replace the value in the B column with the third value from the array.
- Say it finds a row with 3 in column B, 147 in column F -> Then (i, 3).Value = S3.

- If it does not find the criterias in the row, then delete it or hide it (does not matter as Im retrieving only visible cells).

Or are there mabye any other methods that would be more efficient? I've thought of mabye just filtering away the values in the array, then deleting the remains in order to shrink the data-set.

 

[kevin9999]

Not much more I can do Kasper without seeing the data, how it's structured, formated etc. If you can share a sample of your actual data (share a file as you did before) or as @mumps suggested via the XL2BB add in then I'll look at it again, otherwise I'm out.

 

[KasperC]

Not much more I can do Kasper without seeing the data, how it's structured, formated etc. If you can share a sample of your actual data (share a file as you did before) or as @mumps suggested via the XL2BB add in then I'll look at it again, otherwise I'm out.

Hello again.

Heres an updated link with a small batch of example data (de-sensitized).
Example sheet.xlsm | Powered by Box

On Sheet3 is an example of where the data needs to go.

- Filter out a set date, this appears in Sheet1 L1 from an earlier code.
- I need to remove all NUM (col A) that starts with 2000.
- Format all 20/23 (under 13 dig) through Sheet2 (Input col A & "0000", output col H)
- Change the PRO num dependent on criteria such as discussed above (ex. arr: 3,133,S3 -> the 3 in col B turns to S3 if "GRO"/col F is 133)
- Remove the rows of a Pro/Gro combo that does not match any criteria in the arr
- Copy remaining visible data from Sheet1 to the relevant fields in Sheet3

Preferably I'd like the arr to be a notepad or excel sheet with the same path as the file itself - as other users than me will be using it frequently..

I understand if this might be alot to ask for - but if you have any ideas to point me in the right direction those would be much appreciated

 

[kevin9999]

Filter out a set date, this appears in Sheet1 L1 from an earlier code.
- I need to remove all NUM (col A) that starts with 2000.

Does that mean that if the value in column A starts with 2000 but the date in that row in column C doesn't equal the L1 date then that row should not be deleted?