VBA Help

C

chellcie

New Member
Joined
Jul 20, 2022
Messages
4
Office Version
  1. 365
  2. 2021
  3. 2019
Platform
  1. Windows
Im coloring column D based off of the letter in column A. I want to move or copy D after it is colored to a location based of days of the week in column B. would also love for the moved cell to spread out until the return day.

TypeDAY OUTDAY INwhole puzzle pieceSA AMSA PMSU AMSU PMMO AMMO PMTU AMTU PMWE AMWE PMTH AMTH PMFR AMFR PMSA AMSA PM
cWEFR08:00 8398183 qual/petrk/coun/ 14:0008:00 8398183 qual/petrk/coun/ 14:00



Sub COLOR()
'color based on sdc
Range("A2").Select
Do Until IsEmpty(ActiveCell.Value)
DoEvents
If ActiveCell.Value = "s" Then
ActiveCell.Offset(0, 3).Interior.ColorIndex = 40
ActiveCell.Offset(1, 0).Activate
End If
If ActiveCell.Value = "d" Then
ActiveCell.Offset(0, 3).Interior.ColorIndex = 6
ActiveCell.Offset(1, 0).Activate
End If
If ActiveCell.Value = "c" Then
ActiveCell.Offset(0, 3).Interior.ColorIndex = 35
ActiveCell.Offset(1, 0).Activate
End If
If ActiveCell.Value = "" Then
ActiveCell.Offset(1, 3).Activate
End If
Loop
Application.ScreenUpdating = True
End Sub
 

Excel Facts

Show numbers in thousands?
Use a custom number format of #,##0,K. Each comma after the final 0 will divide the displayed number by another thousand
Sort by date Sort by votes
The table has been provided to us starting Saturday and ending Saturday again.
So assuming it starts with Sunday in column F.

TypeDAY OUTDAY INwhole puzzle pieceSU AMSU PMMO AMMO PMTU AMTU PMWE AMWE PMTH AMTH PMFR AMFR PMSA AMSA PM
cWEFR08:00 8398183 qual/petrk/coun/ 14:00
sSUFR12:00 8398183 qual/petrk/coun/ 14:00
cTHFR13:00 8398183 qual/petrk/coun/ 14:00

VBA Code: 
Sub COLOR()
    Dim i As Long
    Dim a As Variant, ret As Variant, AmPm As Long
    Dim cIdx As Variant

    'Making an array has 2 first letter from days
    a = Application.GetCustomListContents(xlDay)
    For i = LBound(a) To UBound(a)
        a(i) = UCase(Left(a(i), 2))
    Next

    'color based on Type
    For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        Select Case Cells(i, "A").Value
        Case "s": cIdx = 40
        Case "d": cIdx = 6
        Case "c": cIdx = 35
        End Select
        Cells(i, "D").Interior.ColorIndex = cIdx

        ret = Application.Match(Cells(i, "B").Value, a, 0)
        'Determine Time from the first 2 letters in column D
        AmPm = IIf(Left(Cells(i, "D").Value, 2) < 12, 0, 1)
        If Not IsError(ret) Then
            With Cells(i, "F").Offset(, (ret - 1) * 2 + AmPm)
                .Value = Cells(i, "D").Value
                .EntireColumn.AutoFit
            End With
        End If
    Next
End Sub
 
Upvote 0
Colo said:
The table has been provided to us starting Saturday and ending Saturday again.
So assuming it starts with Sunday in column F.

TypeDAY OUTDAY INwhole puzzle pieceSU AMSU PMMO AMMO PMTU AMTU PMWE AMWE PMTH AMTH PMFR AMFR PMSA AMSA PM
cWEFR08:00 8398183 qual/petrk/coun/ 14:00
sSUFR12:00 8398183 qual/petrk/coun/ 14:00
cTHFR13:00 8398183 qual/petrk/coun/ 14:00

VBA Code: 
Sub COLOR()
    Dim i As Long
    Dim a As Variant, ret As Variant, AmPm As Long
    Dim cIdx As Variant

    'Making an array has 2 first letter from days
    a = Application.GetCustomListContents(xlDay)
    For i = LBound(a) To UBound(a)
        a(i) = UCase(Left(a(i), 2))
    Next

    'color based on Type
    For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        Select Case Cells(i, "A").Value
        Case "s": cIdx = 40
        Case "d": cIdx = 6
        Case "c": cIdx = 35
        End Select
        Cells(i, "D").Interior.ColorIndex = cIdx

        ret = Application.Match(Cells(i, "B").Value, a, 0)
        'Determine Time from the first 2 letters in column D
        AmPm = IIf(Left(Cells(i, "D").Value, 2) < 12, 0, 1)
        If Not IsError(ret) Then
            With Cells(i, "F").Offset(, (ret - 1) * 2 + AmPm)
                .Value = Cells(i, "D").Value
                .EntireColumn.AutoFit
            End With
        End If
    Next
End Sub
Click to expand...
we would use this for two different sessions so the SA on the left and Right are needed its ok if it wont distinguish the 2 differently if it will just copy in the same for both columns we can go from there. Thanks so much for the response I tried this on my document but it says invalid outside procedure.
 
Upvote 0
I have amended the code for working for the SA on the Left and Right. It will put the same value on both SA.
It seems the code is throwing a compile error with the message "Invalid outside procedure", please let me know which line is highlighted when you got the error.

VBA Code: 
Sub COLOR()
    Dim i As Long
    Dim a As Variant, ret As Variant, AmPm As Long
    Dim cIdx As Variant

    'Making an array has 2 first letter from days
    a = Application.GetCustomListContents(xlDay)
    For i = LBound(a) To UBound(a)
        a(i) = UCase(Left(a(i), 2))
    Next

    'color based on Type
    For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        Select Case Cells(i, "A").Value
        Case "s": cIdx = 40
        Case "d": cIdx = 6
        Case "c": cIdx = 35
        End Select

        If Not IsEmpty(cIdx) Then Cells(i, "D").Interior.ColorIndex = cIdx

        ret = Application.Match(Cells(i, "B").Value, a, 0)
        'Determine Time from the first 2 letters in column D
        AmPm = IIf(Left(Cells(i, "D").Value, 2) < 12, 0, 1)
        If Not IsError(ret) Then
CopyValue:
            With Cells(i, "F").Offset(, (ret) * 2 + AmPm)
                .Value = Cells(i, "D").Value
                .EntireColumn.AutoFit
            End With
            If ret = 7 Then    'Copy the same value to the first "SA"
                ret = 0: GoTo CopyValue
            End If
        End If
    Next
End Sub
 
Upvote 0
Colo said:
I have amended the code for working for the SA on the Left and Right. It will put the same value on both SA.
It seems the code is throwing a compile error with the message "Invalid outside procedure", please let me know which line is highlighted when you got the error.

VBA Code: 
Sub COLOR()
    Dim i As Long
    Dim a As Variant, ret As Variant, AmPm As Long
    Dim cIdx As Variant

    'Making an array has 2 first letter from days
    a = Application.GetCustomListContents(xlDay)
    For i = LBound(a) To UBound(a)
        a(i) = UCase(Left(a(i), 2))
    Next

    'color based on Type
    For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        Select Case Cells(i, "A").Value
        Case "s": cIdx = 40
        Case "d": cIdx = 6
        Case "c": cIdx = 35
        End Select

        If Not IsEmpty(cIdx) Then Cells(i, "D").Interior.ColorIndex = cIdx

        ret = Application.Match(Cells(i, "B").Value, a, 0)
        'Determine Time from the first 2 letters in column D
        AmPm = IIf(Left(Cells(i, "D").Value, 2) < 12, 0, 1)
        If Not IsError(ret) Then
CopyValue:
            With Cells(i, "F").Offset(, (ret) * 2 + AmPm)
                .Value = Cells(i, "D").Value
                .EntireColumn.AutoFit
            End With
            If ret = 7 Then    'Copy the same value to the first "SA"
                ret = 0: GoTo CopyValue
            End If
        End If
    Next
End Sub
Click to expand...
The first line Sub Color () highlights. It does not throw an error it simply does not do anything when I click run it. Two things I am thinking, The first four columns are referenced off other pages in my worksheet, secondly I'm not sure which excel I have could be an issue. Here are some more of the list with different times to work with. Column A-D
cWEFR08:00 8398183 qual/petrk/coun/ 14:00
cWETU08:00 8398185 usfanch// 13:00
dTUFR16:00 8398187 reich/nwdel/ 13:00
cWESA19:00 8398189 mclan/mclan/ 03:00
cTHSA06:00 8398190 parag/costc/greatland// 13:00
cWEFR05:00 8398192 taylo/tripl/snowc/usfsea/ 12:00
cTHSA02:00 8398196 sysse/crown//kro/ 11:00
sWETH16:00 8398198 sysid/ 12:00
sWEFR05:00 8398202 sysse/abc/ 09:00
 
Upvote 0
As I've tried, the procedure works with the list you provided us at #5. A code module can consist of several sections. Possibly, there are some lines not inside a Sub. To make sure, please give it a try after placing it in a new standard module. For avoiding conflict, don't forget to change the name of Sub, like "Sub COLOR2".
 
Upvote 0
Colo said:
As I've tried, the procedure works with the list you provided us at #5. A code module can consist of several sections. Possibly, there are some lines not inside a Sub. To make sure, please give it a try after placing it in a new standard module. For avoiding conflict, don't forget to change the name of Sub, like "Sub COLOR2".
Click to expand...

Colo said:
As I've tried, the procedure works with the list you provided us at #5. A code module can consist of several sections. Possibly, there are some lines not inside a Sub. To make sure, please give it a try after placing it in a new standard module. For avoiding conflict, don't forget to change the name of Sub, like "Sub COLOR2".
Click to expand...
I have it working now, I had to physically copy the 4 columns instead of reference them from one sheet to another. Next question would be can we insert the color onto the calendar coloring from column b (day out) - c (day in) depending on AM/PM timing?
1660167851784.png
 
Upvote 0
You must log in or register to reply here.

Similar threads

N
  • Question
Need Help With Formula
Replies
5
Views
274
Fluff
Fluff
M
  • Solved
Dynamic include/don't include days formula
Replies
2
Views
451
mst3kr
M
Q
  • Solved
Calculating total number of hours within a period, counting only specific days of the week, and specific time intervals.
Replies
8
Views
619
Dave Patton
D
G
  • Question
How can i extract the correct leave time on this code?
Replies
1
Views
356
rlv01
R
D
  • Question
VBA code works when called directly, but not from another routhine
Replies
7
Views
701
davidepstein22
D

Forum statistics

Threads
1,214,657
Messages
6,120,773
Members
448,991
Latest member
Hanakoro

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