Excel VBA Date Issue Transfer from one worksheet to another

**kingsdime29x** · 04-12-2016, 04:15 PM

Hello,

I have a solution that is able to pull data from the source file to the destination file. If you look at my Baseball Stats Solver - Batting file, you will see what files I am using. I have attached the solver file in addition to the source file and the destination file.

However, I have some dates that are double headers, which are indicators with the first game showing a (1) next to the date and a (2) for the second game. These are not the traditional date values as these indicators are needed to determine what game of a doubleheader a player played in. When I go through the solution, it does not correctly carry over the game listed in my destination file named 1978 Toronto Blue Jays - Batting. An example is looking at Rick Bosetti under the Yankees sheetname. He played in doubleheaders (i.e. 05/21/78 (1) and 05/21/78 (2)) and the data is blank for these dates.

I'm not sure if it didn't pick up the information because it is not an actual date. Is there a way to correct this so that it pulls allthe data for even dates that include a (1) and a (2) next to the date?

Here is the code that I am working with:

Option Explicit

Public Const sMailMergeControllerSheetName = "Sheet1"
Public Const sDefaultSourcePathAndFileNameCELL = "F25"
Public Const sDefaultDestinationPathAndFileNameCELL = "F27"


Sub CopyBaseBallStatisticsFromSourceFileToDestinationFile()


  Dim wbDestination As Workbook
  Dim wbSource As Workbook
  
  Dim wsDestination As Worksheet
  Dim wsSource As Worksheet
  
  Dim iRowDestination As Long
  Dim iRowSource As Long
  Dim iRowSourceLastUsed As Long
  
  Dim bAlreadyOpenDestinationFile As Boolean
  Dim bNeedMore As Boolean


  Dim sDate As String
  Dim sDateDestination As String
  Dim sOpp As String
  Dim sDestinationFile As String
  Dim sDestinationSheetName As String
  Dim sFolderExistsMessage As String
  Dim sPath As String
  Dim sPathAndDestinationFile As String
  Dim sPathAndSourceFile As String
  Dim sPathDestinaton As String
  Dim sPathSource As String
  Dim sPlayerName As String
  Dim sSourceFile As String
  Dim sSourceSheetName As String
  
  
  '''''''''''''''''''''''''''''''''''''''''''''
  'Initialization
  '''''''''''''''''''''''''''''''''''''''''''''
  
  'Get current 'Source' file 'Path' and 'File Name'
  'Extract the 'folder' and 'file' names in case there is an error
  sPathAndSourceFile = Trim(ThisWorkbook.Sheets(sMailMergeControllerSheetName).Range(sDefaultSourcePathAndFileNameCELL))
  sPath = LjmExtractPath(sPathAndSourceFile)
  sPathSource = sPath
  sSourceFile = LjmExtractFullFileName(sPathAndSourceFile)


  
  'Make sure the Source folder exists
  If LJMFolderExists(sPath) = True Then
    sFolderExistsMessage = ""
  Else
    sFolderExistsMessage = "WARNING: Folder DOES NOT EXIST."
  End If
  
  'Make sure the Source file has been selected
  If Len(sPathAndSourceFile) = 0 Then
    MsgBox "The Source file has not been selected (is BLANK)." & vbCrLf & _
           "Try again after SELECTING a Source file."
    Exit Sub
  End If
  
  'Make sure the Source file exists
  If LJMFileExists(sPathAndSourceFile) = False Then
    MsgBox "The Source file DOES NOT EXIST." & vbCrLf & _
           "Folder: " & sPath & vbCrLf & _
           "File:       " & sSourceFile & vbCrLf & vbCrLf & _
           sFolderExistsMessage
    Exit Sub
  End If
  
  
  'Get current  'Destination' file 'Path' and 'File Name'
  'Extract the 'folder' and 'file' names in case there is an error
  sPathAndDestinationFile = Trim(ThisWorkbook.Sheets(sMailMergeControllerSheetName).Range(sDefaultDestinationPathAndFileNameCELL))
  sPath = LjmExtractPath(sPathAndDestinationFile)
  sPathDestinaton = sPath
  sDestinationFile = LjmExtractFullFileName(sPathAndDestinationFile)
 


  'Make sure the Destination folder exists
  If LJMFolderExists(sPath) = True Then
    sFolderExistsMessage = ""
  Else
    sFolderExistsMessage = "WARNING: Folder DOES NOT EXIST."
  End If
  
  'Make sure the Destination file has been selected
  If Len(sPathAndDestinationFile) = 0 Then
    MsgBox "The Destination file has not been selected (is BLANK)." & vbCrLf & _
           "Try again after SELECTING a Destination file."
    Exit Sub
  End If
  
  'Make sure the Destination file exists
  If LJMFileExists(sPathAndDestinationFile) = False Then
    MsgBox "The Destination File DOES NOT EXIST." & vbCrLf & _
           "Folder: " & sPath & vbCrLf & _
           "File:       " & sDestinationFile & vbCrLf & vbCrLf & _
           sFolderExistsMessage
    Exit Sub
  End If
  
  '''''''''''''''''''''''''''''''''''''''''''''
  'Process Data Files
  '''''''''''''''''''''''''''''''''''''''''''''
  
  'Open the Source Data File if it is not already open
  If LjmIsWorkbookOpen(sSourceFile) = True Then
    Set wbSource = Workbooks(sSourceFile)
  Else
    Set wbSource = Workbooks.Open(Filename:=sPathAndSourceFile)
  End If
  
  'Open the Destination Data File if it is not already open
  If LjmIsWorkbookOpen(sDestinationFile) = True Then
    Set wbDestination = Workbooks(sDestinationFile)
    bAlreadyOpenDestinationFile = True
  Else
    Set wbDestination = Workbooks.Open(Filename:=sPathAndDestinationFile)
  End If
  
  For Each wsSource In wbSource.Worksheets
  
    'Get the next name in the Source File
    sSourceSheetName = wsSource.Name
    sPlayerName = sSourceSheetName
    'Debug.Print sSourceSheetName
    
    'Sort by Team and then by Date
    wsSource.Activate
    wsSource.Cells.Sort _
      Key1:=Range("B2"), Order1:=xlAscending, _
      Key2:=Range("A2"), Order2:=xlAscending, _
      Header:=xlYes, _
      OrderCustom:=1, MatchCase:=False, _
      Orientation:=xlTopToBottom, _
      DataOption1:=xlSortNormal, _
      DataOption2:=xlSortNormal
      
    'Get the Last Row Used in the 'Source Sheet'
    iRowSourceLastUsed = wsSource.Range("A:A").Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  
    'Process each row in the Source Sheet
    For iRowSource = 2 To iRowSourceLastUsed
  
      'Read each item in the Source Sheet
      sDate = wsSource.Cells(iRowSource, "A")
      sOpp = Trim(wsSource.Cells(iRowSource, "B"))   'Remove leading/trailing spaces
      'Debug.Print sSourceSheetName, iRowSource, sDate, sOpp
      
      If UCase(sDestinationSheetName) <> UCase(sOpp) Then
      
        'Display an Error Message and EXIT if the 'Team Name' Sheet
        If LjmWorkbookAndSheetExists(sDestinationFile, sOpp) = False Then
          MsgBox "TERMINATING due to Data Integrity Error.  The following 'Team Name' " & vbCrLf & _
                 "Sheet DOES NOT EXIST on the Destination File: " & sOpp & vbCrLf & vbCrLf & _
                 "Source Folder: " & sPathSource & vbCrLf & _
                 "Source File:  " & sSourceFile & vbCrLf & _
                 "Source File Sheet Name: " & sSourceSheetName & vbCrLf & vbCrLf & _
                 "Destination Folder: " & sPathDestinaton & vbCrLf & _
                 "Destination File:       " & sDestinationFile & vbCrLf & vbCrLf & _
                 "Possible reasons for the error include:" & vbCrLf & _
                 "a. Incorrect Source File Name was selected." & vbCrLf & _
                 "b. Incorrect Destination File Name was selected." & vbCrLf & _
                 "c. Team Name spelled INCORRECTLY in Source File Column 'B'." & vbCrLf & _
                 "d. Team Name spelled INCORRECTLY as a Destination File Sheet Name." & vbCrLf & _
                 ""
          GoTo MYEXIT
        End If
      
        'Create the 'Destination Sheet' Object
        Set wsDestination = wbDestination.Sheets(sOpp)
        sDestinationSheetName = wsDestination.Name
        
        'Find the Player in the Destination Sheet (Match is ALWAYS 'Case Insensitive')
        'NOTE: A runtime error will occur if there is NO MATCH
        Const nExactMATCH = 0
        On Error Resume Next
        iRowDestination = Application.WorksheetFunction.Match(sPlayerName, wsDestination.Columns(2), nExactMATCH)
        Err.Clear
        On Error GoTo 0
        
        'Display an Error Message and EXIT if the 'Player Name' cannot be found on the Destination Sheet
        If iRowDestination = 0 Then
        
          MsgBox "TERMINATING due to Data Integrity Error. The following 'Player Name'" & vbCrLf & _
                 "DOES NOT EXIST on the Destination Sheet: " & sPlayerName & vbCrLf & _
                  "Source Folder: " & sPathSource & vbCrLf & _
                 "Source File:  " & sSourceFile & vbCrLf & _
                 "Source File Sheet Name: " & sSourceSheetName & vbCrLf & vbCrLf & _
                 "Destination Folder: " & sPathDestinaton & vbCrLf & _
                 "Destination File:       " & sDestinationFile & vbCrLf & _
                 "Destination File Sheet Name: " & sDestinationSheetName & vbCrLf & vbCrLf & _
                 "Possible reasons for the error include:" & vbCrLf & _
                 "a. Incorrect Source File Name was selected." & vbCrLf & _
                 "b. Incorrect Destination File Name was selected." & vbCrLf & _
                 "c. Player Name spelled INCORRECTLY as a Source File Sheet Name.." & vbCrLf & _
                 "d. Player Name spelled INCORRECTLY in Destination File Column 'B'." & vbCrLf & _
                 ""
          GoTo MYEXIT
        End If
        
        'Debug.Print "Destination Sheet", sPlayerName, wsDestination.Name, iRowDestination
      End If
      
      'Match Dates on 'Source' and 'Destination' Sheets until either NO MORE DATA or 'Name' Sentinel is found
      bNeedMore = True
      While bNeedMore = True
    
        'Increment the Destination Sheet Row Number
        iRowDestination = iRowDestination + 1
    
        'Get the NEXT 'Destination Date'
        sDateDestination = Trim(wsDestination.Cells(iRowDestination, "B").Value)
    
        'Debug.Print iRowDestination, sDate, sDateDestination
        
        'No more processing for this Destination Date if the 'NAME' sentinel is found (go to the next Source Date)
        'No more processing for this Destination Date if there is NO MORE DATA in the file
        'If the Source and Destination Data are the same, copy the data to the Destination Sheet
        '  and go to the next Source Date
        'Otherwise, go to the next 'Destination Date'
        If UCase(sDateDestination) = "NAME" Then
          bNeedMore = False
        ElseIf Len(sDateDestination) = 0 Then
          bNeedMore = False
        ElseIf sDate = sDateDestination Then
          
          bNeedMore = False
          
          'Copy values from Source to Destination
          wsDestination.Cells(iRowDestination, "C").Value = wsSource.Cells(iRowSource, "C").Value
          wsDestination.Cells(iRowDestination, "D").Value = wsSource.Cells(iRowSource, "D").Value
          wsDestination.Cells(iRowDestination, "E").Value = wsSource.Cells(iRowSource, "E").Value
          wsDestination.Cells(iRowDestination, "F").Value = wsSource.Cells(iRowSource, "F").Value
          wsDestination.Cells(iRowDestination, "G").Value = wsSource.Cells(iRowSource, "G").Value
          
          wsDestination.Cells(iRowDestination, "I").Value = wsSource.Cells(iRowSource, "H").Value
          wsDestination.Cells(iRowDestination, "J").Value = wsSource.Cells(iRowSource, "I").Value
          wsDestination.Cells(iRowDestination, "K").Value = wsSource.Cells(iRowSource, "J").Value
                 
        End If
      Wend
      
    Next iRowSource
        
  Next wsSource
  
  
  'Close the Source data file (EVEN if it was already open - because Sheets were sorted)
  wbSource.Close SaveChanges:=False
  
  'Save the Destination Data File
  'Close the Destination data files (if it was not already open)
  wbDestination.Save
  If bAlreadyOpenDestinationFile = False Then
    wbDestination.Close SaveChanges:=False
  End If
    
  'Display a termination message
  MsgBox "Data Copy Success."
  


MYEXIT:
  '''''''''''''''''''''''''''''''''''''''''''''
  'Termination
  '''''''''''''''''''''''''''''''''''''''''''''
  
  'Clear object pointers
  Set wbSource = Nothing
  Set wbDestination = Nothing
  Set wsSource = Nothing
  Set wsDestination = Nothing


End Sub


Sub GetThisWorkbookPathForDefaultFiles()
  'This puts the DEFAULT Excel/Word file paths and file names in the PALE GREEN cells on 'Sheet1'


  Const sDefaultSourceFileNAME = "1978 Batting Gamelogs.xlsx"
  Const sDefaultDestinationFileNAME = "1978 Toronto Blue Jays - Batting.xlsx"


  Dim sExcelPathAndFileName As String
  Dim sPath As String
  Dim sWordlPathAndFileName As String
  
  'Get the path for the Workbook that is running the code
  sPath = ThisWorkbook.Path & "\"
  
  'Create the combined path and file names
  sExcelPathAndFileName = sPath & sDefaultDestinationFileNAME
  sWordlPathAndFileName = sPath & sDefaultSourceFileNAME


  'Put the names in the 'PALE GREEN' cells
  Workbooks(ThisWorkbook.Name).Sheets(sMailMergeControllerSheetName).Range(sDefaultDestinationPathAndFileNameCELL) = sExcelPathAndFileName
  Workbooks(ThisWorkbook.Name).Sheets(sMailMergeControllerSheetName).Range(sDefaultSourcePathAndFileNameCELL) = sWordlPathAndFileName
    
  'Save the Update and Keep the Workbook open
  ThisWorkbook.Save
    
  MsgBox "The Document Names have been set to DEFAULT values." & vbCrLf & _
         "Folder: " & sPath & vbCrLf & _
         "Source File Name:           " & sDefaultSourceFileNAME & vbCrLf & _
         "Destination File Name:   " & sDefaultDestinationFileNAME & vbCrLf & _
         ""
         
End Sub






Sub GetPathAndFileNameForSourceFile()
  'This gets the path and file name for the Source file
  
  Dim sPathAndFileName As String
  Dim sStartStringPath As String
  Dim sUserPrompt As String
  
  'Get current 'Path' and 'File Name'
  sPathAndFileName = Trim(ThisWorkbook.Sheets(sMailMergeControllerSheetName).Range(sDefaultSourcePathAndFileNameCELL))


  'Set the start path
  If Len(sPathAndFileName) = 0 Then
    'There is no file - set the start path to the folder that this file is in
    sStartStringPath = ThisWorkbook.Path & "\"
  Else
    'There is a file - set the start path to the folder of the existing file
    sStartStringPath = LjmExtractPath(sPathAndFileName)
  End If
  
  
  sUserPrompt = "Select the Source File and 'Click' on 'OK'"
  
  sStartStringPath = sStartStringPath & "*.xls*"
    
  sPathAndFileName = LjmGetFileUsingFilePicker(sStartStringPath, sUserPrompt)
  
  
  If sPathAndFileName = "" Then
    MsgBox "No Change to Current Source File Name per User Request."
  Else
  
    Workbooks(ThisWorkbook.Name).Sheets(sMailMergeControllerSheetName).Range(sDefaultSourcePathAndFileNameCELL) = sPathAndFileName
    
    'Save the Update and Keep the Workbook open
    ThisWorkbook.Save
    
    MsgBox "The 'Source File' Path and File Name " & vbCrLf & "was PERMANENTLY CHANGED per User Request."
  End If


End Sub




Sub GetPathAndFileNameForDestinationFile()
  'This gets the path and file name for the Destination file
  
  Dim sPathAndFileName As String
  Dim sStartStringPath As String
  Dim sUserPrompt As String
  
  'Get current 'Path' and 'File Name'
  sPathAndFileName = Trim(ThisWorkbook.Sheets(sMailMergeControllerSheetName).Range(sDefaultDestinationPathAndFileNameCELL))


  'Set the start path
  If Len(sPathAndFileName) = 0 Then
    'There is no file - set the start path to the folder that this file is in
    sStartStringPath = ThisWorkbook.Path & "\"
  Else
    'There is a file - set the start path to the folder of the existing file
    sStartStringPath = LjmExtractPath(sPathAndFileName)
  End If
  
  
  sUserPrompt = "Select a Destination File Name and 'Click' on 'OK'"
  
  sStartStringPath = sStartStringPath & "*.xls*"
    
  sPathAndFileName = LjmGetFileUsingFilePicker(sStartStringPath, sUserPrompt)
  
  
  If sPathAndFileName = "" Then
    MsgBox "No Change to Current Destination File Name per User Request."
  Else
  
    Workbooks(ThisWorkbook.Name).Sheets(sMailMergeControllerSheetName).Range(sDefaultDestinationPathAndFileNameCELL) = sPathAndFileName
    
    'Save the Update and Keep the Workbook open
    ThisWorkbook.Save
    
    MsgBox "The 'Destination File' Path and File Name " & vbCrLf & "was PERMANENTLY CHANGED per User Request."
  End If


End Sub

Anything that can help resolve this would be very helpful and appreciated. Thanks in advance for your help.

**SamT** · 04-12-2016, 10:56 PM

Sounds like you need a new way to indicate doubleheaders. Excel and VBA do NOT recognise "05/21/78 (1)" as a Date. To them, it is just another random string of characters. To Excel and VBA, this is a Date: "42473.0060171296." For humans, Excel displays that number as "4/13/16 12:11AM." (The long integer 42473 by itself displays as 4/13/16 or as 4/13/16 12:00AM)

To recap; Excel stores, (and VBA uses,) Dates and Times as decimal numbers, where the integer part is the date and the decimal part is the time.

If you use the actual game Date/Times , Excel will sort DoubleHeaders in Time order and Excel and VBA will recognise the second Date/Time as being larger than the first.

If you manually enter a Doubleheader, use 4/13/16 6am and 4/13/16 12pm.

With VBA Game 1 = DateAdd("h", GameDate, 6) and game2 = DateAdd("h", GameDate, 12). Mathematically in VBA, DateSerial(GameDate) + one of 0.25, 0.5, 0.75. .25 for 6Am, .5 for noon, and for the rare tripleheader, .75for 6PM.

To compare two games to see if they are a doubleheader: If Absolute(Game A - Game B) >= 1 Then Not a double Header.

Alternately, add a helper column, empty for normal games, with "d" for doubleheaders and "t" for triples

**kingsdime29x** · 04-13-2016, 07:40 AM

Thanks. I tried your suggestion and added the DateAdd and DateSerial information. I keep running into errors when trying to run the updated code with the date indicators. I'm not sure why it is not pulling up the values now. Any other tips or could you help me find where this logic with the DateAdd and DateSerial need to go for this to work properly? Thank you for you help so far.

Option Explicit


Public Const sMailMergeControllerSheetName = "Sheet1"
Public Const sDefaultSourcePathAndFileNameCELL = "F25"
Public Const sDefaultDestinationPathAndFileNameCELL = "F27"


Sub CopyBaseBallStatisticsFromSourceFileToDestinationFile()


  Dim wbDestination As Workbook
  Dim wbSource As Workbook
  
  Dim wsDestination As Worksheet
  Dim wsSource As Worksheet
  
  Dim iRowDestination As Long
  Dim iRowSource As Long
  Dim iRowSourceLastUsed As Long
  
  Dim bAlreadyOpenDestinationFile As Boolean
  Dim bNeedMore As Boolean


  Dim sDate As String
  Dim sDateDestination As String
  Dim GameDate As String
  Dim sOpp As String
  Dim sDestinationFile As String
  Dim sDestinationSheetName As String
  Dim sFolderExistsMessage As String
  Dim sPath As String
  Dim sPathAndDestinationFile As String
  Dim sPathAndSourceFile As String
  Dim sPathDestinaton As String
  Dim sPathSource As String
  Dim sPlayerName As String
  Dim sSourceFile As String
  Dim sSourceSheetName As String
  
  
  '''''''''''''''''''''''''''''''''''''''''''''
  'Initialization
  '''''''''''''''''''''''''''''''''''''''''''''
  
  'Get current 'Source' file 'Path' and 'File Name'
  'Extract the 'folder' and 'file' names in case there is an error
  sPathAndSourceFile = Trim(ThisWorkbook.Sheets(sMailMergeControllerSheetName).Range(sDefaultSourcePathAndFileNameCELL))
  sPath = LjmExtractPath(sPathAndSourceFile)
  sPathSource = sPath
  sSourceFile = LjmExtractFullFileName(sPathAndSourceFile)


  
  'Make sure the Source folder exists
  If LJMFolderExists(sPath) = True Then
    sFolderExistsMessage = ""
  Else
    sFolderExistsMessage = "WARNING: Folder DOES NOT EXIST."
  End If
  
  'Make sure the Source file has been selected
  If Len(sPathAndSourceFile) = 0 Then
    MsgBox "The Source file has not been selected (is BLANK)." & vbCrLf & _
           "Try again after SELECTING a Source file."
    Exit Sub
  End If
  
  'Make sure the Source file exists
  If LJMFileExists(sPathAndSourceFile) = False Then
    MsgBox "The Source file DOES NOT EXIST." & vbCrLf & _
           "Folder: " & sPath & vbCrLf & _
           "File:       " & sSourceFile & vbCrLf & vbCrLf & _
           sFolderExistsMessage
    Exit Sub
  End If
  
  
  'Get current  'Destination' file 'Path' and 'File Name'
  'Extract the 'folder' and 'file' names in case there is an error
  sPathAndDestinationFile = Trim(ThisWorkbook.Sheets(sMailMergeControllerSheetName).Range(sDefaultDestinationPathAndFileNameCELL))
  sPath = LjmExtractPath(sPathAndDestinationFile)
  sPathDestinaton = sPath
  sDestinationFile = LjmExtractFullFileName(sPathAndDestinationFile)
 


  'Make sure the Destination folder exists
  If LJMFolderExists(sPath) = True Then
    sFolderExistsMessage = ""
  Else
    sFolderExistsMessage = "WARNING: Folder DOES NOT EXIST."
  End If
  
  'Make sure the Destination file has been selected
  If Len(sPathAndDestinationFile) = 0 Then
    MsgBox "The Destination file has not been selected (is BLANK)." & vbCrLf & _
           "Try again after SELECTING a Destination file."
    Exit Sub
  End If
  
  'Make sure the Destination file exists
  If LJMFileExists(sPathAndDestinationFile) = False Then
    MsgBox "The Destination File DOES NOT EXIST." & vbCrLf & _
           "Folder: " & sPath & vbCrLf & _
           "File:       " & sDestinationFile & vbCrLf & vbCrLf & _
           sFolderExistsMessage
    Exit Sub
  End If
  
  '''''''''''''''''''''''''''''''''''''''''''''
  'Process Data Files
  '''''''''''''''''''''''''''''''''''''''''''''
  
  'Open the Source Data File if it is not already open
  If LjmIsWorkbookOpen(sSourceFile) = True Then
    Set wbSource = Workbooks(sSourceFile)
  Else
    Set wbSource = Workbooks.Open(Filename:=sPathAndSourceFile)
  End If
  
  'Open the Destination Data File if it is not already open
  If LjmIsWorkbookOpen(sDestinationFile) = True Then
    Set wbDestination = Workbooks(sDestinationFile)
    bAlreadyOpenDestinationFile = True
  Else
    Set wbDestination = Workbooks.Open(Filename:=sPathAndDestinationFile)
  End If
  
  For Each wsSource In wbSource.Worksheets
  
    'Get the next name in the Source File
    sSourceSheetName = wsSource.Name
    sPlayerName = sSourceSheetName
    'Debug.Print sSourceSheetName
    
    'Sort by Team and then by Date
    wsSource.Activate
    wsSource.Cells.Sort _
      Key1:=Range("B2"), Order1:=xlAscending, _
      Key2:=Range("A2"), Order2:=xlAscending, _
      Header:=xlYes, _
      OrderCustom:=1, MatchCase:=False, _
      Orientation:=xlTopToBottom, _
      DataOption1:=xlSortNormal, _
      DataOption2:=xlSortNormal
      
    'Get the Last Row Used in the 'Source Sheet'
    iRowSourceLastUsed = wsSource.Range("A:A").Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  
    'Process each row in the Source Sheet
    For iRowSource = 2 To iRowSourceLastUsed
  
      'Read each item in the Source Sheet
      sDate = wsSource.Cells(iRowSource, "A")
      sOpp = Trim(wsSource.Cells(iRowSource, "B"))   'Remove leading/trailing spaces
      'Debug.Print sSourceSheetName, iRowSource, sDate, sOpp
      
      If UCase(sDestinationSheetName) <> UCase(sOpp) Then
      
        'Display an Error Message and EXIT if the 'Team Name' Sheet
        If LjmWorkbookAndSheetExists(sDestinationFile, sOpp) = False Then
          MsgBox "TERMINATING due to Data Integrity Error.  The following 'Team Name' " & vbCrLf & _
                 "Sheet DOES NOT EXIST on the Destination File: " & sOpp & vbCrLf & vbCrLf & _
                 "Source Folder: " & sPathSource & vbCrLf & _
                 "Source File:  " & sSourceFile & vbCrLf & _
                 "Source File Sheet Name: " & sSourceSheetName & vbCrLf & vbCrLf & _
                 "Destination Folder: " & sPathDestinaton & vbCrLf & _
                 "Destination File:       " & sDestinationFile & vbCrLf & vbCrLf & _
                 "Possible reasons for the error include:" & vbCrLf & _
                 "a. Incorrect Source File Name was selected." & vbCrLf & _
                 "b. Incorrect Destination File Name was selected." & vbCrLf & _
                 "c. Team Name spelled INCORRECTLY in Source File Column 'B'." & vbCrLf & _
                 "d. Team Name spelled INCORRECTLY as a Destination File Sheet Name." & vbCrLf & _
                 ""
          GoTo MYEXIT
        End If
      
        'Create the 'Destination Sheet' Object
        Set wsDestination = wbDestination.Sheets(sOpp)
        sDestinationSheetName = wsDestination.Name
        
        'Find the Player in the Destination Sheet (Match is ALWAYS 'Case Insensitive')
        'NOTE: A runtime error will occur if there is NO MATCH
        Const nExactMATCH = 0
        On Error Resume Next
        iRowDestination = Application.WorksheetFunction.Match(sPlayerName, wsDestination.Columns(2), nExactMATCH)
        Err.Clear
        On Error GoTo 0
        
        'Display an Error Message and EXIT if the 'Player Name' cannot be found on the Destination Sheet
        If iRowDestination = 0 Then
        
          MsgBox "TERMINATING due to Data Integrity Error. The following 'Player Name'" & vbCrLf & _
                 "DOES NOT EXIST on the Destination Sheet: " & sPlayerName & vbCrLf & _
                  "Source Folder: " & sPathSource & vbCrLf & _
                 "Source File:  " & sSourceFile & vbCrLf & _
                 "Source File Sheet Name: " & sSourceSheetName & vbCrLf & vbCrLf & _
                 "Destination Folder: " & sPathDestinaton & vbCrLf & _
                 "Destination File:       " & sDestinationFile & vbCrLf & _
                 "Destination File Sheet Name: " & sDestinationSheetName & vbCrLf & vbCrLf & _
                 "Possible reasons for the error include:" & vbCrLf & _
                 "a. Incorrect Source File Name was selected." & vbCrLf & _
                 "b. Incorrect Destination File Name was selected." & vbCrLf & _
                 "c. Player Name spelled INCORRECTLY as a Source File Sheet Name.." & vbCrLf & _
                 "d. Player Name spelled INCORRECTLY in Destination File Column 'B'." & vbCrLf & _
                 ""
          GoTo MYEXIT
        End If
        
        'Debug.Print "Destination Sheet", sPlayerName, wsDestination.Name, iRowDestination
      End If
      
      'Match Dates on 'Source' and 'Destination' Sheets until either NO MORE DATA or 'Name' Sentinel is found
      bNeedMore = True
      While bNeedMore = True
      
        DateAdd = Game1("h", GameDate, 6)
        DateAdd = Game2("h", GameDate, 12)
        
        DateSerial (GameDate) + 0.25, 0.5, 0.75
    
        'Increment the Destination Sheet Row Number
        iRowDestination = iRowDestination + 1
    
        'Get the NEXT 'Destination Date'
        sDateDestination = Trim(wsDestination.Cells(iRowDestination, "B").Value)
    
        'Debug.Print iRowDestination, sDate, sDateDestination
        
        'No more processing for this Destination Date if the 'NAME' sentinel is found (go to the next Source Date)
        'No more processing for this Destination Date if there is NO MORE DATA in the file
        'If the Source and Destination Data are the same, copy the data to the Destination Sheet
        '  and go to the next Source Date
        'Otherwise, go to the next 'Destination Date'
        If UCase(sDateDestination) = "NAME" Then
          bNeedMore = False
        ElseIf Len(sDateDestination) = 0 Then
          bNeedMore = False
        ElseIf sDate = sDateDestination Then
          
          bNeedMore = False
          
          'Copy values from Source to Destination
          wsDestination.Cells(iRowDestination, "C").Value = wsSource.Cells(iRowSource, "C").Value
          wsDestination.Cells(iRowDestination, "D").Value = wsSource.Cells(iRowSource, "D").Value
          wsDestination.Cells(iRowDestination, "E").Value = wsSource.Cells(iRowSource, "E").Value
          wsDestination.Cells(iRowDestination, "F").Value = wsSource.Cells(iRowSource, "F").Value
          wsDestination.Cells(iRowDestination, "G").Value = wsSource.Cells(iRowSource, "G").Value
          
          wsDestination.Cells(iRowDestination, "I").Value = wsSource.Cells(iRowSource, "H").Value
          wsDestination.Cells(iRowDestination, "J").Value = wsSource.Cells(iRowSource, "I").Value
          wsDestination.Cells(iRowDestination, "K").Value = wsSource.Cells(iRowSource, "J").Value
                 
        End If
      Wend
      
    Next iRowSource
        
  Next wsSource
  
  
  'Close the Source data file (EVEN if it was already open - because Sheets were sorted)
  wbSource.Close SaveChanges:=False
  
  'Save the Destination Data File
  'Close the Destination data files (if it was not already open)
  wbDestination.Save
  If bAlreadyOpenDestinationFile = False Then
    wbDestination.Close SaveChanges:=False
  End If
    
  'Display a termination message
  MsgBox "Data Copy Success."
  


MYEXIT:
  '''''''''''''''''''''''''''''''''''''''''''''
  'Termination
  '''''''''''''''''''''''''''''''''''''''''''''
  
  'Clear object pointers
  Set wbSource = Nothing
  Set wbDestination = Nothing
  Set wsSource = Nothing
  Set wsDestination = Nothing


End Sub


Sub GetThisWorkbookPathForDefaultFiles()
  'This puts the DEFAULT Excel/Word file paths and file names in the PALE GREEN cells on 'Sheet1'


  Const sDefaultSourceFileNAME = "1978 Batting Gamelogs.xlsx"
  Const sDefaultDestinationFileNAME = "1978 Toronto Blue Jays - Batting.xlsx"


  Dim sExcelPathAndFileName As String
  Dim sPath As String
  Dim sWordlPathAndFileName As String
  
  'Get the path for the Workbook that is running the code
  sPath = ThisWorkbook.Path & "\"
  
  'Create the combined path and file names
  sExcelPathAndFileName = sPath & sDefaultDestinationFileNAME
  sWordlPathAndFileName = sPath & sDefaultSourceFileNAME


  'Put the names in the 'PALE GREEN' cells
  Workbooks(ThisWorkbook.Name).Sheets(sMailMergeControllerSheetName).Range(sDefaultDestinationPathAndFileNameCELL) = sExcelPathAndFileName
  Workbooks(ThisWorkbook.Name).Sheets(sMailMergeControllerSheetName).Range(sDefaultSourcePathAndFileNameCELL) = sWordlPathAndFileName
    
  'Save the Update and Keep the Workbook open
  ThisWorkbook.Save
    
  MsgBox "The Document Names have been set to DEFAULT values." & vbCrLf & _
         "Folder: " & sPath & vbCrLf & _
         "Source File Name:           " & sDefaultSourceFileNAME & vbCrLf & _
         "Destination File Name:   " & sDefaultDestinationFileNAME & vbCrLf & _
         ""
         
End Sub






Sub GetPathAndFileNameForSourceFile()
  'This gets the path and file name for the Source file
  
  Dim sPathAndFileName As String
  Dim sStartStringPath As String
  Dim sUserPrompt As String
  
  'Get current 'Path' and 'File Name'
  sPathAndFileName = Trim(ThisWorkbook.Sheets(sMailMergeControllerSheetName).Range(sDefaultSourcePathAndFileNameCELL))


  'Set the start path
  If Len(sPathAndFileName) = 0 Then
    'There is no file - set the start path to the folder that this file is in
    sStartStringPath = ThisWorkbook.Path & "\"
  Else
    'There is a file - set the start path to the folder of the existing file
    sStartStringPath = LjmExtractPath(sPathAndFileName)
  End If
  
  
  sUserPrompt = "Select the Source File and 'Click' on 'OK'"
  
  sStartStringPath = sStartStringPath & "*.xls*"
    
  sPathAndFileName = LjmGetFileUsingFilePicker(sStartStringPath, sUserPrompt)
  
  
  If sPathAndFileName = "" Then
    MsgBox "No Change to Current Source File Name per User Request."
  Else
  
    Workbooks(ThisWorkbook.Name).Sheets(sMailMergeControllerSheetName).Range(sDefaultSourcePathAndFileNameCELL) = sPathAndFileName
    
    'Save the Update and Keep the Workbook open
    ThisWorkbook.Save
    
    MsgBox "The 'Source File' Path and File Name " & vbCrLf & "was PERMANENTLY CHANGED per User Request."
  End If


End Sub




Sub GetPathAndFileNameForDestinationFile()
  'This gets the path and file name for the Destination file
  
  Dim sPathAndFileName As String
  Dim sStartStringPath As String
  Dim sUserPrompt As String
  
  'Get current 'Path' and 'File Name'
  sPathAndFileName = Trim(ThisWorkbook.Sheets(sMailMergeControllerSheetName).Range(sDefaultDestinationPathAndFileNameCELL))


  'Set the start path
  If Len(sPathAndFileName) = 0 Then
    'There is no file - set the start path to the folder that this file is in
    sStartStringPath = ThisWorkbook.Path & "\"
  Else
    'There is a file - set the start path to the folder of the existing file
    sStartStringPath = LjmExtractPath(sPathAndFileName)
  End If
  
  
  sUserPrompt = "Select a Destination File Name and 'Click' on 'OK'"
  
  sStartStringPath = sStartStringPath & "*.xls*"
    
  sPathAndFileName = LjmGetFileUsingFilePicker(sStartStringPath, sUserPrompt)
  
  
  If sPathAndFileName = "" Then
    MsgBox "No Change to Current Destination File Name per User Request."
  Else
  
    Workbooks(ThisWorkbook.Name).Sheets(sMailMergeControllerSheetName).Range(sDefaultDestinationPathAndFileNameCELL) = sPathAndFileName
    
    'Save the Update and Keep the Workbook open
    ThisWorkbook.Save
    
    MsgBox "The 'Destination File' Path and File Name " & vbCrLf & "was PERMANENTLY CHANGED per User Request."
  End If


End Sub

**SamT** · 04-13-2016, 01:13 PM

Date/Times are not Type String, they are Type DATE.

If you are going to use Strings to hold "Dates" you will need to use CDate(StringThatLooksLikeADate) to convert them to Type Date.

dDate = CDate(sDate)

Given String GameDate = "05/21/78 (1)":

dGameDate = CDate(GameDate)

will Raise an Error.

You can use that Style doubleheader notation with

If Len(GameDate) > 8 then 
   bDoubleHeader = True 
'The next  bit of code is supposed to be in this code block. 
'For some reason, the VBAX Server keeps inserting CODE Tags here

'This bit of code is supposed to be in the previous code block
dGameDate CDate(Left(GameDate, 8))
If CLng(Mid(GameDate, 11, 1)) = 1 Then
      bFirstGame = True
   Else: bSecondGame = True
   End If
Else
   dGameDate CDate(GameDate)
   bDoubleHeader = False
End If

Thread: Excel VBA Date Issue Transfer from one worksheet to another

Thread Tools

Display

Excel VBA Date Issue Transfer from one worksheet to another

Posting Permissions