VBA Solution to do a -4:00 hour GMT time calculate on imported Data in two Colums for all imported rows

S

smd747

Board Regular
Joined
Apr 24, 2011
Messages
214
The code below imports and formats my data. What I need to do is the values in the following Columns need I need to add a calculation to adjust for GMT Time -4 currently.
The column with the original Arrival Time Date is Q imported to the I column
The column with the original Departure Time Date is T imported to the J column.
Do I need to create a Loop to recalculate ? I attempted to
Code: 
Range("I" & Row).Value = .Range("Q" & i).Value - 4
            Range("J" & Row).Value = .Range("T" & i).Value  -4

From both sides but it did not work.

Here is all my code that works but does not calculate the GMT -4

Code: 
Option Explicit

Sub FormatCustomerDeliveryData()

Dim i                   As Long
Dim j                   As Long
Dim D                   As Long
Dim Row                 As Long
Dim StartRow            As Long
Dim LastRow             As Long
Dim FinalRow            As Long
Dim cell                As Range
Dim Highlight           As Boolean
Dim Prompt              As String
Dim Path                As String
Dim Data()              As String
Dim StartTime           As Date
Dim start_dt            As Date
Dim end_dt              As Date
Dim WkbData             As Workbook
Dim WSReport            As Worksheet

    Prompt = "Select the file to process."
    Path = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", , Prompt)
    If Path = "False" Then
        GoTo ExitSub:
    End If

    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    Set WkbData = Workbooks.Open(Filename:=Path, ReadOnly:=True)
    Workbooks.Add (1)
    
    ' Set Up Colunm Headers
    
     ActiveSheet.Name = "Customer Deliveries Report"
    Range("A1").Value = "Route Date"
    Range("B1").Value = "Vehicle Description"
    Range("C1").Value = "Order No"
    Range("D1").Value = "Stop No"
    Range("E1").Value = "Customer"
    Range("F1").Value = "Town"
    Range("G1").Value = "Zip Code"
    Range("H1").Value = "Driver"
    Range("I1").Value = "Arrival"
    Range("J1").Value = "Departure"
    Range("L1").Value = "Distance"
    Range("K1").Value = "Stop Duration"
    Range("M1").Value = "TWI Open Time"
    Range("N1").Value = "TWI Close Time"
        
    'Format Row Headers
    
    Range("A1").EntireRow.HorizontalAlignment = xlCenter
    Range("A1").EntireRow.VerticalAlignment = xlCenter
    Range("A1").EntireRow.Font.Bold = True
    Range("A1").EntireRow.WrapText = True
    Cells.Font.Name = "Arial"
    Cells.Font.Size = 8
    
    Range("A:A").EntireColumn.ColumnWidth = 10
    Range("B:B").EntireColumn.ColumnWidth = 20
    Range("C:C").EntireColumn.ColumnWidth = 12
    Range("D:D").EntireColumn.ColumnWidth = 10
    Range("E:E").EntireColumn.ColumnWidth = 36
    Range("F:F").EntireColumn.ColumnWidth = 16
    Range("G:G").EntireColumn.ColumnWidth = 10
    Range("H:H").EntireColumn.ColumnWidth = 25
    Range("I:I").EntireColumn.ColumnWidth = 14
    Range("J:J").EntireColumn.ColumnWidth = 14
    Range("K:K").EntireColumn.ColumnWidth = 14
    Range("L:L").EntireColumn.ColumnWidth = 16
    Range("M:M").EntireColumn.ColumnWidth = 14
    Range("N:N").EntireColumn.ColumnWidth = 14
    
    

''''''''''''''''''''''''''''    'Format Colunms

    Range("I:J").NumberFormat = "h\:mm AM/PM"
    Range("L:L").NumberFormat = "0.00"
    Range("M:N").NumberFormat = "h\:mm AM/PM"
    Range("K:K").NumberFormat = "[h]:mm"
    
    
    Range("A1:N1").Interior.Color = RGB(141, 180, 226)
        
    Call AddBorders(Range("A1:n1"))
    
    Range("A2").Select
    ActiveWindow.FreezePanes = True
    ActiveWindow.DisplayGridlines = True
    
'*************************************************************
            
    With WkbData.Sheets(1)
        LastRow = .Range("A" & .Rows.Count).End(xlUp).Row


        FrmProgress.TextBoxProgress.Width = 0
        FrmProgress.LabelPrompt.Caption = "Processing Data: "
        FrmProgress.LabelTimeRemaining.Caption = "Time Remaining: Calculating"
        FrmProgress.TextBoxDummy.SetFocus
        FrmProgress.Show vbModeless
        DoEvents
''''''''''''
        Row = 1
        StartRow = Row
        StartTime = Now
        For i = 4 To LastRow
            FrmProgress.TextBoxProgress.Width = (i / LastRow) * 200
            FrmProgress.LabelPrompt.Caption = "Processing Data: " & i & " of " & LastRow
            FrmProgress.LabelTimeRemaining.Caption = "Time Remaining: " & IIf(i < 50, "Calculating", Format(((Now - StartTime) / i) * LastRow - (Now - StartTime), "h:mm:ss"))
            DoEvents
                Row = Row + 1
' FIRST RANGE SHEET BEING IMPORTED TO, 2ND RANGE EXPORTED FROM
            Range("A" & Row).Value = .Range("A" & i).Value
            Range("B" & Row).Value = .Range("B" & i).Value
            Range("C" & Row).Value = .Range("D" & i).Value
            Range("D" & Row).Value = .Range("E" & i).Value
            Range("E" & Row).Value = .Range("F" & i).Value
            Range("F" & Row).Value = .Range("J" & i).Value
            Range("G" & Row).Value = .Range("L" & i).Value
            Range("H" & Row).Value = .Range("N" & i).Value
            Range("I" & Row).Value = .Range("Q" & i).Value  ''***Need to take this value and adjust to GMT Time -4  (4:00 formatted [H]:MM)
            Range("J" & Row).Value = .Range("T" & i).Value  ''***Need to take this value and adjust to GMT Time -4  (4:00 formatted [H]:MM)  
            Range("L" & Row).Value = .Range("W" & i).Value
            Range("M" & Row).Value = .Range("AB" & i).Value
            Range("N" & Row).Value = .Range("AC" & i).Value

            ' Range K is a calculated field

        Next i
    End With
    
    '*Close Imported Data WorkBook
    
    WkbData.Close SaveChanges:=False
    
    'Continue Cleaning Up
    
'    FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
' For i = 2 To FinalRow
'            Data = Split(Replace(Range("A" & i).Value, "]", "", , , vbTextCompare), "[", , vbTextCompare)
'            Range("A" & i).Value = Trim(Data(0))
'            Range("B" & i).Value = Trim(Data(1))
'        Next i
'
'  For i = 2 To FinalRow
'            Data = Split(Replace(Range("C" & i).Value, "]", "", , , vbTextCompare), "[", , vbTextCompare)
'            Range("C" & i).Value = Trim(Data(0))
'            Range("D" & i).Value = Trim(Data(1))
'        Next i
'
        

    'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    On Error Resume Next


Cells(2, 11).Select
Do
    If IsEmpty(ActiveCell) Then
        If IsEmpty(ActiveCell.Offset(0, -1)) Then
            ActiveCell.Value = ""
        Else
            ActiveCell.FormulaR1C1 = "=RC[-1]-RC[-2]"

ActiveCell.Value = ActiveCell.Value
        End If
    End If
    ActiveCell.Offset(1, 0).Select
    Loop Until IsEmpty(ActiveCell.Offset(0, -1))

Cells(2, 11).Select

    Range("A:A").EntireColumn.HorizontalAlignment = xlCenter
    Range("C:D").EntireColumn.HorizontalAlignment = xlCenter
    Range("G:G").EntireColumn.HorizontalAlignment = xlCenter
    Range("I:L").EntireColumn.HorizontalAlignment = xlCenter
    Range("M:N").EntireColumn.HorizontalAlignment = xlCenter


'*********************************************************************************

'Dim cell As Range
   
    For Each cell In Range("B:B").SpecialCells(xlCellTypeConstants)
        If cell Like "Route ID*" Then
               cell.Value = Trim(Mid(cell.Value, InStr(cell.Value, "-") + 1))
        End If
    Next cell
    
  Cells(2, 4).Select
      
'################################--Adjust drivers stops per address
  ' This loop runs as long as there is something in the next column
    Do While Not IsEmpty(ActiveCell.Offset(0, 1))
    ActiveCell.FormulaR1C1 = "=IF(EXACT(RC[1],R[-1]C[1]),0,1)"
    ActiveCell.Offset(1, 0).Select
    Loop
     Cells(2, 4).Select
Range("D:D").EntireColumn.Value = Range("D:D").EntireColumn.Value

ExitSub:

    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub


Here is what I am attempting:
Customer Deliveries Report

ABCDEFGHIJKLMNO
1 Column I need to subtract 4:00 hours from each RowColumn J need to subtract 4:00 hours from each Row
2
3
4Route DateVehicle DescriptionOrder NoStop NoCustomerTownZip CodeDriverArrivalDepartureStop DurationDistanceTWI Open TimeTWI Close TimeSales Amount
510/3/20123037541Customer-1NEW YORK10011Brian 10:26 AM11:08 AM0:4256.7511:00 AM12:00 PM$314.58
610/3/20123037481Customer-2NEW YORK10001Brian 12:09 PM12:44 PM0:354.5412:00 PM1:00 PM$2,306.00
710/3/20123037541Customer-3NEW YORK10001Brian 1:15 PM1:25 PM0:104.371:00 PM2:00 PM$123.10
810/3/20123037511Customer-4NEW YORK10013Brian 1:51 PM3:18 PM1:265.3611:00 AM3:00 PM$1,689.40
9
10
11

<COLGROUP> <COL style="WIDTH: 30px; FONT-WEIGHT: bold"><COL style="WIDTH: 93px"><COL style="WIDTH: 110px"><COL style="WIDTH: 110px"><COL style="WIDTH: 93px"><COL style="WIDTH: 60px"><COL style="WIDTH: 60px"><COL style="WIDTH: 93px"><COL style="WIDTH: 38px"><COL style="WIDTH: 74px"><COL style="WIDTH: 70px"><COL style="WIDTH: 78px"><COL style="WIDTH: 52px"><COL style="WIDTH: 86px"><COL style="WIDTH: 89px"><COL style="WIDTH: 80px"> </COLGROUP><TBODY>
</TBODY>


Excel tables to the web >> Excel Jeanie HTML 4

Any idea's and direction to accomplish this calculation would be appreciated
 
Sort by date Sort by votes
Andrew

Here is how I got it to work by adding part of the loopformula to deduct the 4 hours - TimeValue("04:00")
by adding that to the input code where it takes it from column Q from the raw data does the calculation and adds the result of the calculation into Row I.



Code: 
' FIRST RANGE SHEET BEING IMPORTED TO, 2ND RANGE EXPORTED FROM
            Range("A" & Row).Value = .Range("A" & i).Value
            Range("B" & Row).Value = .Range("B" & i).Value
            Range("C" & Row).Value = .Range("D" & i).Value
            Range("D" & Row).Value = .Range("E" & i).Value
            Range("E" & Row).Value = .Range("F" & i).Value
            Range("F" & Row).Value = .Range("J" & i).Value
            Range("G" & Row).Value = .Range("L" & i).Value
            Range("H" & Row).Value = .Range("N" & i).Value
            Range("I" & Row).Value = .Range("Q" & i).Value - TimeValue("04:00")
            Range("J" & Row).Value = .Range("T" & i).Value - TimeValue("04:00")
            Range("L" & Row).Value = .Range("W" & i).Value
            Range("M" & Row).Value = .Range("AB" & i).Value
            Range("N" & Row).Value = .Range("AC" & i).Value


Thanks for baiting me in the right direct and giving me a hint of the clue.

Thank you much appreciated
 
Upvote 0

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying
You must log in or register to reply here.

Similar threads

R
  • Question
Macro not working after adding two new items
Replies
4
Views
138
myall_blues
myall_blues
S
  • Question
Using VBA to Flag and Calculate Overlapping Shift Times
Replies
0
Views
84
Snort
S
J
  • Solved
VBA setting times of Copy & paste specific columns if the value is greater than 1
Replies
5
Views
301
JECYN
J
I
  • Question
Data formatting for Chart
Replies
3
Views
336
IREALLYambatman
I
Q
  • Solved
Calculating total number of hours within a period, counting only specific days of the week, and specific time intervals.
Replies
8
Views
649
Dave Patton
D

Forum statistics

Threads
1,215,453
Messages
6,124,929
Members
449,195
Latest member
Stevenciu

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