VBA Code Help.. Please :)

VBAN0oB

New Member
Joined
Oct 19, 2022
Messages
10
Office Version
  1. 365
Platform
  1. Windows
I am trying to develop a business tracker that is not a manual process. I need it to do the following:
1. If we received a submission the data is entered in lets say A2:N2 and the boss wants the rows colored alternating blue. -- I've done this with conditional formatting, however the number of rows above the [BOUND ACCOUNTS] merged cells fluctuates when we get new submissions or decline them.
2. If we bind the submission then we put the bound premium in K2 and the row needs to be cut/paste below the [BOUND ACCOUNTS] merged cells on the spreadsheet, but then the rows below bound accounts are colored alternating green.- My code does this but not correctly.
3. If the user puts a premium in column K in error and it moves below, then they remove the premium I need it to move back up above [BOUND ACCOUNTS]
4. If we do not bind the account then we put a P in column A and the row cuts/pastes to sheet (pipeline) -- My current code does this part
5. If we decline the account then we put a D in column A and the row cuts/pastes to sheet (declined)-- I am not sure how to add another rule for this
6. Lastly I need the accounts to be sorted in date order newest to oldest automatically without the end user having to manually click sort each time.

I realize that this is super extra, but our other systems are so antiquated that EVERYTHING is done via excel right now and its very time consuming. If you are so able and willing, please help. My eyeballs can't take anymore YouTube videos at 3 am.

Here is what I have under module "October"
VBA Code:
Sub Worksheet_SelectionChange(ByVal Target As Range)
    ' Run a macro that is located inside of a module
    Call Worksheet_SelectionChangeOctober
  End Sub

Sub MoveBasedOnValueOctober()
    Call MoveBasedOnValueOctober
End Sub

Sub Worksheet_SelectionChangeOctober()
'Updated by Extendoffice 20220520
    Dim xRg As Range
    Dim xTxt As String
    Dim xCell As Range
    Dim xEndRow As Long
    Dim I As Long
    On Error Resume Next
    If ActiveWindow.RangeSelection.Count > 1 Then
      xTxt = ActiveWindow.RangeSelection.AddressLocal
    Else
      xTxt = ActiveSheet.UsedRange.AddressLocal
    End If
lOne:
    Set xRg = Range("K2:K50")
    If xRg Is Nothing Then Exit Sub
    If xRg.Columns.Count > 1 Or xRg.Areas.Count > 1 Then
        GoTo lOne
    End If
    xEndRow = xRg.Rows.Count + xRg.Row
    Application.ScreenUpdating = False
    For I = xRg.Rows.Count To 1 Step -1
        If xRg.Cells(I) > 0 Then
        xRg.Cells(I).EntireRow.Cut
        Rows(xEndRow).Offset(3, 0).EntireRow.Insert
    End If
    Next
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub


Here is what I have under Sheet7 (October)

VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    ' Run a macro that is located inside of a module
    Call Worksheet_SelectionChangeOctober
    Call MoveBasedOnValueOctober
End Sub

Sub MoveBasedOnValueOctober()
'Created by Excel 10 Tutorial
    Dim xRg As Range
    Dim xCell As Range
    Dim A As Long
    Dim B As Long
    Dim C As Long
    A = Worksheets("October").UsedRange.Rows.Count
    B = Worksheets("Pipeline").UsedRange.Rows.Count
    If B = 1 Then
       If Application.WorksheetFunction.CountA(Worksheets("Pipeline").UsedRange) = 0 Then B = 0
    End If
    Set xRg = Worksheets("October").Range("A1:A" & A)
    On Error Resume Next
    Application.ScreenUpdating = False
    For A = 2 To xRg.Count
        If CStr(xRg(A).Value) = "Y" Then
            xRg(A).EntireRow.Copy Destination:=Worksheets("Pipeline").Range("A" & B + 1)
            xRg(A).EntireRow.Delete
            If CStr(xRg(A).Value) = "Y" Then
                A = A - 1
            End If
            B = B + 1
        End If
    Next
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Selection.End (xlUp)
End Sub
 

Attachments

  • Capture.PNG
    Capture.PNG
    62 KB · Views: 9
Last edited by a moderator:

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
Welcome to the forum. :)

To be honest, given that you have 365, I wouldn't use code at all. I'd suggest one sheet with a table where all the submissions are entered, then something like a sheet each for Bound, Pipeline and Declined using a simple FILTER formula to extract the relevant data to each. Or using Power Query so that you get a banded table automatically.
 
Upvote 0
Thank you for your advice, however that will not work for the mgmt team I am dealing with. If someone could help me with the code to move from one table to another on the same sheet maybe that would be easier.
 
Upvote 0
I started working on this and have some ideas to help but it would help greatly if you could upload to Dropbox (or other such) a representative workbook to use as testing. I will have additional questions but for now try to upload that workbook.
 
Upvote 0

Forum statistics

Threads
1,223,907
Messages
6,175,300
Members
452,633
Latest member
DougMo

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