Excel VBS issues

J

juneau730

Board Regular
Joined
Jun 7, 2018
Messages
111
So, after much searching the wonderful web, I still can find a solution. I am trying to create an Excel VBS Script that does multiple functions. I have some of it working (yay me), but now I need some help.

First part of it needs to find data in a specific column, that is greater than a number value and less than a subsequent number value. Once it identifies this it needs to move the rows within this range to a different worksheet. This what I have so far and it keeps hanging on the <> area...
Dim i, LastRow
LastRow = Sheets("RAW DATA_AD All Users Report").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Inactive Users").Range("A2:S7500").ClearContents
For i = 2 To LastRow
If Sheets("RAW DATA_AD All Users Report").Cells(i, "L").Value = ">30 & <90" Then
Sheets("RAW DATA_AD All Users Report").Cells(i, "L").EntireRow.Copy Destination:=Sheets("Inactive Users").Range("A" & Rows.Count).End(xlUp).Offset(1)
LastRow = Sheets("RAW DATA_AD All Users Report").Range("A" & Rows.Count).End(xlUp).Row
End If
Next i
End Sub

The other part is an IF AND function. I need to it find in a column the IF condition of "FALSE" followed by an AND IF a second column has a >= to a number value. Once it identifies this it needs to move the rows to a different worksheet.

Dim i, LastRow
LastRow = Sheets("RAW DATA_AD All Users Report").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Password Mangement").Range("A2:S7500").ClearContents
For i = 2 To LastRow
If Sheets("RAW DATA_AD All Users Report").Cells(i, "E").Value = "FALSE" And Sheets("RAW DATA_AD All Users Report").Cells(i, "L").Value = ">= 90" Then
Sheets("RAW DATA_AD All Users Report").Cells(i, "K").EntireRow.Copy Destination:=Sheets("Password Mangement").Range("A" & Rows.Count).End(xlUp).Offset(1)
LastRow = Sheets("RAW DATA_AD All Users Report").Range("A" & Rows.Count).End(xlUp).Row
End If
Next i
End Sub
 
Sort by date Sort by votes
This is the code up to now, with the above mentioned status

Code: 
Sub t()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, sh4 As Worksheet, sh5 As Worksheet, sh6 As Worksheet, c As Range
Set sh1 = Sheets("RAW DATA_AD All Users Report")
Set sh2 = Sheets("Inactive Users")
Set sh3 = Sheets("Never Logged On")
Set sh4 = Sheets("Inactive Over 90-Days Enabled")
Set sh5 = Sheets("Inactive Over 365-Days")
Set sh6 = Sheets("Password Mangement")
sh2.Range("A2:S7500").ClearContents
    For Each c In sh1.Range("L2", sh1.Cells(Rows.Count, "L").End(xlUp))
        If c.Value > 30 And c.Value < 90 Then
            c.EntireRow.Copy sh2.Cells(Rows.Count, 1).End(xlUp)(2)
        End If
    Next
sh3.Range("A2:S7500").ClearContents
    For i = 2 To LastRow
    If Sheets("sh1").Cells("K").Value = "" Then
        Sheets("sh1").Cells("K").Cells.Clear
    End If
    If Sheets("sh1").Cells("K").Value = "" Then
        Sheets("sh1").Cells("K").EntireRow.Copy Destination:=Sheets("sh3").Range("A" & Rows.Count).End(xlUp).Offset(1)
        LastRow = Sheets("sh1").Range("A" & Rows.Count).End(xlUp).Row
        End If
    Next
sh4.Range("A2:S7500").ClearContents
    For Each c In sh1.Range("L2", sh1.Cells(Rows.Count, "L").End(xlUp))
        If c.Value >= 90 Then
            c.EntireRow.Copy sh4.Cells(Rows.Count, 1).End(xlUp)(2)
        End If
    Next
sh5.Range("A2:S7500").ClearContents
    For Each c In sh1.Range("L2", sh1.Cells(Rows.Count, "L").End(xlUp))
        If c.Value >= 365 Then
            c.EntireRow.Copy sh5.Cells(Rows.Count, 1).End(xlUp)(2)
        End If
    Next
sh6.Range("A2:S7500").ClearContents
    For Each c In sh1.Range("M2", sh1.Cells(Rows.Count, "M").End(xlUp))
        If c = False And c.Offset(7).Value >= 90 Then
            c.EntireRow.Copy sh6.Cells(Rows.Count, 1).End(xlUp)(2)
        End If
    Next
End Sub
 
Upvote 0

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.
I have revised this so that it only makes one pass on the data base. With over 5000 rows, it could take quite a while to run multiple loops.
Code: 
Sub t2()
 Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, sh4 As Worksheet, sh5 As Worksheet, sh6 As Worksheet, i As Long, lr As Long
 Set sh1 = Sheets("RAW DATA_AD All Users Report")
 Set sh2 = Sheets("Inactive Users")
 Set sh3 = Sheets("Never Logged On")
 Set sh4 = Sheets("Inactive Over 90-Days Enabled")
 Set sh5 = Sheets("Inactive Over 365-Days")
 Set sh6 = Sheets("Password Mangement")
 lr = sh1.Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
    For Each sh In ThisWorkbook.Sheets
       If sh.Name <> sh1.Name Then
           sh.Range("A:S").Offset(1).ClearContents
       End If
    Next
    For i = 2 To lr
        With sh1
            If .Cells(i, "L").Value > 30 And .Cells(i, "L") < 90 And .Cells(i, "K") <> "" Then
                .Rows(i).Copy sh2.Cells(Rows.Count, 1).End(xlUp)(2)
            End If
            If .Cells(i, "K").Value = "" Then
                .Cells(i, "K").Clear
                .Rows(i).Copy sh3.Cells(Rows.Count, 1).End(xlUp)(2)
            End If
            If .Cells(i, "H") = False And .Cells(i, "K") <> "" And .Cells(i, "L") >= 90 Then
                .Rows(i).Copy sh4.Cells(Rows.Count, 1).End(xlUp)(2)
            End If
            If .Cells(i, "H") = True And .Cells(i, "K") <> "" And .Cells(i, "L") >= 365 Then
                .Rows(i).Copy sh5.Cells(Rows.Count, 1).End(xlUp)(2)
            End If
            If .Cells(i, "E") = False And .Cells(i, "K") <> "" And .Cells(i, "M") >= 90 Then
                .Rows(i).Copy sh6.Cells(Rows.Count, 1).End(xlUp)(2)
            End If
       End With
    Next
 End Sub
 
Upvote 0
I'm validating everything, but it looks like we might have gone backwards a bit by getting rid of the multiple passes.
I'll let you know in a bit.
 
Upvote 0
Yeah.. Some how it's not correct and I am going blind trying to compare them anymore. I don't know if this will help or not, but this is a simplified word break down of what needs to happen.
Code: 
[B]Inactive Users [/B]
Go Back [B]Sh1[/B]
Column [B]H[/B] (Disabled) = [B]FALSE[/B]
Column [B]K[/B] (Last Logon) = [B]NotBlank[/B]
Column [B]L[/B] (LL_ElapsedDays) = [B]>30 and <90[/B]
[B]Copy to Sh2[/B]
 
[B]NEVER Logged on Users [/B]
Go Back [B]Sh1[/B]
Column [B]H[/B] (Disabled) = [B]FALSE[/B]
Column [B]K[/B] (Last Logon) = [B]Blank[/B]
[B]Copy to Sh3[/B]
 
[B]Inactive Users – 90-Days Inactivity [/B]
Go Back [B]Sh1[/B]
Column [B]H[/B] (Disabled) = [B]FALSE[/B]
Column [B]K[/B] (Last Logon) = [B]NotBlank[/B]
Column [B]L[/B] (LL_ElapsedDays) = [B]>= 90[/B]
[B]Copy to Sh4[/B]
 
[B]Inactive Users – 365-Days Inactivity [/B]
Go Back [B]Sh1[/B]
Column [B]H[/B] (Disabled) = [B]TRUE[/B]
Column [B]K[/B] (Last Logon) = [B]NotBlank[/B]
Column [B]L[/B] (LL_ElapsedDays) = [B]>= 365[/B]
[B]Copy to Sh5[/B]
 
[B]Password Management[/B]
Go Back [B]Sh1[/B]
Column [B]H[/B] (Disabled) = [B]FALSE[/B]
Column [B]K[/B] (Last Logon) = [B]NotBlank[/B]
Column [B]L[/B] (LL_ElapsedDays) = [B]>= 90[/B]
[B]Copy to Sh6[/B]
 
Upvote 0
Sorry I missed a few things it needs to do.

For sh2 - sh6 only it still needs to perform .Range("A2:S7500").ClearContents before it copies the data
For the Never logged on Users, on sh1 it still needs to .Cells("K").Cells.Clear after it identifies them as blank, before it copies the data

I am walking away from this for now. My brain is mush.

BTW, the multiple loops will be fine, for those that were working in that manner, it wasn't that slow.
 
Last edited:
Upvote 0
It is not necessary to revert to multiple loops. This code should work if your parameters are correct for each If statement. You are basically asking five questions and only one can have an answer of True or none will be true and it will bypass that row. I note that in Post #14 you changed parameters for sh6 from columns E and M to H and L which then duplicates the parameters for sh4. If Post #14 was in error then change them back in the code below.

Code: 
Sub t3()
 Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, sh4 As Worksheet, sh5 As Worksheet, sh6 As Worksheet, i As Long, lr As Long
 Set sh1 = Sheets("RAW DATA_AD All Users Report")
 Set sh2 = Sheets("Inactive Users")
 Set sh3 = Sheets("Never Logged On")
 Set sh4 = Sheets("Inactive Over 90-Days Enabled")
 Set sh5 = Sheets("Inactive Over 365-Days")
 Set sh6 = Sheets("Password Mangement")
 lr = sh1.Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
    For Each sh In ThisWorkbook.Sheets
       If sh.Name <> sh1.Name Then
           sh.Range("A:S").Offset(1).ClearContents
       End If
    Next
    For i = 2 To lr
        With sh1
            If .Cells(i, "H") = False And .Cells(i, "L").Value > 30 And .Cells(i, "L") < 90 And .Cells(i, "K") <> "" Then
                .Rows(i).Copy sh2.Cells(Rows.Count, 1).End(xlUp)(2)
            End If
            If .Cells(i, "H") = False And .Cells(i, "K").Value = "" Then
                .Cells(i, "K").Clear
                .Rows(i).Copy sh3.Cells(Rows.Count, 1).End(xlUp)(2)
            End If
            If .Cells(i, "H") = False And .Cells(i, "K") <> "" And .Cells(i, "L") >= 90 Then
                .Rows(i).Copy sh4.Cells(Rows.Count, 1).End(xlUp)(2)
            End If
            If .Cells(i, "H") = True And .Cells(i, "K") <> "" And .Cells(i, "L") >= 365 Then
                .Rows(i).Copy sh5.Cells(Rows.Count, 1).End(xlUp)(2)
            End If
            'This sh6 now appears to duplicate sh4 parmeters.  Do "H" and "L" need to change?
            If .Cells(i, "H") = False And .Cells(i, "K") <> "" And .Cells(i, "L") >= 90 Then
                .Rows(i).Copy sh6.Cells(Rows.Count, 1).End(xlUp)(2)
            End If
       End With
    Next
 End Sub
 
Upvote 0
I think that got it. I ran out of time to do some final testing but will look at it more on Monday.
I'll let you know and thanks so much for the help.
 
Upvote 0
juneau730 said:
I think that got it. I ran out of time to do some final testing but will look at it more on Monday.
I'll let you know and thanks so much for the help.
Click to expand...

You're welcome,
regards, JLG
 
Upvote 0
JLG, I was able to do a bit more testing this morning and with a little tweaking, I think we have it. I will test it a bit more, just to verify.

Is there a way to add a cell must contain condition? I'd like this cell condition but in this format it's not working, I believe because the cell doesn't = but the term OU=Users is within the cell.

Code: 
and .Cells(i, "S").Value = OU=Users Then
 
Upvote 0
JLGWhiz, was hoping you could help me fix one last hiccup. I am trying to get this to ignore/skip over any row that does not contain "OU=Users" in column "S" on sh1. I've been trying a bunch of different delete row if cell does not contain strings and they all either need debugging or if debugging doesn't pop, it just doesn't do anything. In red is the last attempt I made that didn't error out, but isn't working.

Deleting any row that doesn't contain "OU=Users" in column "S" on sh1 would work too

Code: 
Sub ADCleanUp() Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, sh4 As Worksheet, sh5 As Worksheet, sh6 As Worksheet, i As Long, lr As Long
 Set sh1 = Sheets("RAW DATA_AD All Users Report")
 Set sh2 = Sheets("Inactive Users")
 Set sh3 = Sheets("Never Logged On")
 Set sh4 = Sheets("Inactive Over 90-Days Enabled")
 Set sh5 = Sheets("Inactive Over 365-Days")
 Set sh6 = Sheets("Password Mangement")
 lr = sh1.Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
    For Each sh In ThisWorkbook.Sheets
    sh2.Range("A2:S7500").ClearContents
    sh3.Range("A2:S7500").ClearContents
    sh4.Range("A2:S7500").ClearContents
    sh5.Range("A2:S7500").ClearContents
    sh6.Range("A2:S7500").ClearContents
    Next
    For i = 2 To lr
        With sh1
[COLOR=#ff0000]            If .Cells(i, "S").Value <> OU=Users Then .Rows(i, lr).Delete[/COLOR]
            If .Cells(i, "K").Value = "" Then
                .Cells(i, "K").Cells.Clear
            End If
            If .Cells(i, "L").Value > 30 And .Cells(i, "L") < 90 And .Cells(i, "K") <> "" Then
                .Rows(i).Copy sh2.Cells(Rows.Count, 1).End(xlUp)(2)
            End If
            If .Cells(i, "H") = False And .Cells(i, "K").Value = "" Then
                .Rows(i).Copy sh3.Cells(Rows.Count, 1).End(xlUp)(2)
            End If
            If .Cells(i, "H") = False And .Cells(i, "K") <> "" And .Cells(i, "L") >= 90 Then
                .Rows(i).Copy sh4.Cells(Rows.Count, 1).End(xlUp)(2)
            End If
            If .Cells(i, "H") = True And .Cells(i, "K") <> "" And .Cells(i, "L") >= 365 Then
                .Rows(i).Copy sh5.Cells(Rows.Count, 1).End(xlUp)(2)
            End If
            If .Cells(i, "E") = False And .Cells(i, "K") <> "" And .Cells(i, "M") >= 90 Then
                .Rows(i).Copy sh6.Cells(Rows.Count, 1).End(xlUp)(2)
            End If
       End With
    Next
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Solved
VBA/Macro: Adding Pivot table with connection string
Replies
1
Views
175
Jette3173
J
G
  • Solved
Skip Row When Column Word Meet
2
Replies
14
Views
358
Peter_SSs
Peter_SSs
I
  • Solved
Apply text to specific cell
Replies
2
Views
89
ipbr21054
I
D
  • Solved
Error 1004
2
Replies
18
Views
352
dmt32
D
G
  • Solved
Button for a For Loop
Replies
3
Views
122
Joe4
Joe4

Forum statistics

Threads
1,223,911
Messages
6,175,337
Members
452,637
Latest member
Ezio2866

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