"For" but only visible cells issue

K

KasperC

New Member
Joined
May 11, 2023
Messages
49
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
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.
VBA Code: 
        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?

VBA Code: 
        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
 
Sort by date Sort by votes

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.
I suppose the logic built into Sheet2 can be built into the code itself if that makes it easier - the sheet was made to do the job manually so that they could copy in multiple values at the same time.


The logic is as follows: (might be easier to follow by looking in Sheet2. Problem is I havent looked into how to integrate this logic into the code, yet..)

20/23 Value & "0000" = X

0

&

X

&

if (the following number) equals 10 Then "0", Else

3*(MOD(X;10)+(MOD(X;1000)-MOD(X;100))/100+(MOD(X;100000)-MOD(X;10000))/10000+(MOD(X;10000000)-MOD(X;1000000))/1000000+(MOD(X;1000000000)-MOD(X;100000000))/100000000+(MOD(X;100000000000)-MOD(X;10000000000))/10000000000)

+

((MOD(X;100)-MOD(X;10))/10+(MOD(X;10000)-MOD(X;1000))/1000+(MOD(X;1000000)-MOD(X;100000))/100000+(MOD(X;100000000)-MOD(X;10000000))/10000000+(MOD(X;10000000000)-MOD(X;1000000000))/1000000000+(MOD(X;1000000000000)-MOD(X;100000000000))/100000000000)

+

10

-

MOD(
3*(MOD(X;10)+(MOD(X;1000)-MOD(X;100))/100+(MOD(X;100000)-MOD(X;10000))/10000+(MOD(X;10000000)-MOD(X;1000000))/1000000+(MOD(X;1000000000)-MOD(X;100000000))/100000000+(MOD(X;100000000000)-MOD(X;10000000000))/10000000000)
+
((MOD(X;100)-MOD(X;10))/10+(MOD(X;10000)-MOD(X;1000))/1000+(MOD(X;1000000)-MOD(X;100000))/100000+(MOD(X;100000000)-MOD(X;10000000))/10000000+(MOD(X;10000000000)-MOD(X;1000000000))/1000000000+(MOD(X;1000000000000)-MOD(X;100000000000))/100000000000));10
)

-
(
3*(MOD(X;10)+(MOD(X;1000)-MOD(X;100))/100+(MOD(X;100000)-MOD(X;10000))/10000+(MOD(X;10000000)-MOD(X;1000000))/1000000+(MOD(X;1000000000)-MOD(X;100000000))/100000000+(MOD(X;100000000000)-MOD(X;10000000000))/10000000000)
+
((MOD(X;100)-MOD(X;10))/10+(MOD(X;10000)-MOD(X;1000))/1000+(MOD(X;1000000)-MOD(X;100000))/100000+(MOD(X;100000000)-MOD(X;10000000))/10000000+(MOD(X;10000000000)-MOD(X;1000000000))/1000000000+(MOD(X;1000000000000)-MOD(X;100000000000))/100000000000)
)
 
Last edited:
Upvote 0
KasperC said:
I suppose the logic built into Sheet2 can be built into the code itself if that makes it easier - the sheet was made to do the job manually so that they could copy in multiple values at the same time.
Click to expand...
Here

VBA Code: 
Dim M As String
Dim M1 As String
Dim M2 As String

M = ws.Cells(i, 1) & "0000" 'location of the 20/23 number
M1 = 3*((M Mod 10)+((M Mod 1000)-(M Mod 100))/100+((M Mod 100000)-(M Mod 10000))/10000+((M Mod 10000000)-(M Mod 1000000))/1000000+((M Mod 1000000000)-(M Mod 10000000))/10000000+((M Mod 100000000000)-(M Mod 100000000))/100000000)+(((M Mod 100)-(M Mod 10))/10+((M Mod 10000)-(M Mod 1000))/1000+((M Mod 1000000)-(M Mod 100000))/100000+((M Mod 100000000)-(M Mod 1000000))/1000000+((M Mod 10000000000)-(M Mod 1000000000))/1000000000+((M Mod 1000000000000)-(M Mod 100000000000))/100000000000)
M2 = M1+10-(M1;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
 
Upvote 0
Last try tonight before I switch the laptop off. Try this on a copy of your workbook:

VBA Code: 
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
 
Upvote 0
Solution
kevin9999 said:
Last try tonight before I switch the laptop off. Try this on a copy of your workbook:
Click to expand...

I'm getting a "Run-time error '13': Type mismatch" at DtFltr = ws.Range("L1").Value

L1 contains the value: 19.06.2023 for the data-set I sent you

 
Upvote 0
KasperC said:
I'm getting a "Run-time error '13': Type mismatch" at DtFltr = ws.Range("L1").Value

L1 contains the value: 19.06.2023 for the data-set I sent you

Click to expand...
L1 was blank on the sample file you shared, I assumed it would have been in the same format as the date column- d/mm/yyyy. I'll look at it tomorrow. In the meantime, how was the rest of the formatting looking?
 
Upvote 0
kevin9999 said:
L1 was blank on the sample file you shared, I assumed it would have been in the same format as the date column- d/mm/yyyy. I'll look at it tomorrow. In the meantime, how was the rest of the formatting looking?
Click to expand...
Everything else looked flawless! Really quick too. Amazing..

I can still see the lines with for example an 8 in the B column, which wasnt in any of the criterias in your code - but i suppose the filter was supposed to do something about that? Or that you havent added the "deletion" step yet?

The L1 value came from a form-input in my main-file, you can paste this into L1 in the sample-file just for good mesure "19.06.2023".
Comes in the format "DD.MM.YYYY" - I tried changing the "Format(DtFltr, "d/mm/yyyy")" to "Format(DtFltr, "dd.mm.yyyy") without any different results.

I used " ws.Range("C1").AutoFilter Field:=3, Criteria1:=DtFltr" to filter in my previous code, which worked just fine.
 
Upvote 0
Please try the amended code below on a copy of your workbook.

VBA Code: 
Option Explicit
Sub KasperC_V2()
    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 "3|139"
                b(i, 1) = "SC"
            Case "3|354"
                b(i, 1) = "SC"
            Case "8|133"
                b(i, 1) = "S8"
            Case "8|147"
                b(i, 1) = "S8"
            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, DtFltr
        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
 
Upvote 0
Still mismatch at the same line.

I also looked around and made this. Do you think this may be an ok way of doing it?

In the notepad, its formated like this:
3/133
J3
3/148
J3
3/139
JC
3/354
JC

It matches a row in 0-format, and pairs it in 1-format (so it pickes the line after the match it found.
This was the closest thing I managed to figure regarding my arr question.
But you dont have to look too much into this now, I can probably figure out how to implement it into your code.

LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
Dim FSO As Object, MyFile As Object
Dim FileName As String, Arr As Variant
Dim qn As String

FileName = "pathtonotepad.txt"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set MyFile = FSO.OpenTextFile(FileName, 1)
Arr = Split(MyFile.ReadAll, vbNewLine)

Dim y As Integer
If vk.Text = "Option1" Or vk.Text = "Option2" Then
For y = LastRow To 2 Step -1
qn = ws.Cells(y, 2) & "/" & ws.Cells(y, 6)

If IsError(Application.match(qn, Arr, 0)) Then
ws.Cells(y, 2).EntireRow.Delete Shift:=xlUp
Else
ws.Cells(y, 2) = Arr(Application.WorksheetFunction.match(qn, Arr, 0))
End If
Next y
Else
For y = LastRow To 2 Step -1
ws.Cells(y, 2) = "S" & ws.Cells(y, 2)
Next y
End If
 
Upvote 0
KasperC said:
Still mismatch at the same line.
Click to expand...
I put a date into cell L1 in the format you described in post #27:
KasperC said:
Comes in the format "DD.MM.YYYY"
Click to expand...
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 (y):)
 
Upvote 0
You must log in or register to reply here.

Similar threads

G
  • Solved
Combine input box (multiple criteria)
Replies
4
Views
103
gomes123
G
G
  • Solved
If Else Loop macro running slow, anyway to speed it up?
Replies
9
Views
291
Alex Blakenburg
A
D
  • Solved
Remove Absolute References
Replies
3
Views
89
HighAndWilder
H
Z
  • Question Question
VBA Process Flow Chart using Shapes & Connectors
Replies
2
Views
180
zlotowlosapl
Z
S
  • Solved
date formatting within vba
Replies
3
Views
244
shina67
S

Forum statistics

Threads
1,223,885
Messages
6,175,187
Members
452,616
Latest member
intern444

Share this page

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