PDA

View Full Version : [SOLVED] 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(sDefaultSourc ePathAndFileNameCELL))
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(sDefaultDesti nationPathAndFileNameCELL))
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(sD efaultDestinationPathAndFileNameCELL) = sExcelPathAndFileName
Workbooks(ThisWorkbook.Name).Sheets(sMailMergeControllerSheetName).Range(sD efaultSourcePathAndFileNameCELL) = 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(sDefaultSourc ePathAndFileNameCELL))


'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(sD efaultSourcePathAndFileNameCELL) = 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(sDefaultDesti nationPathAndFileNameCELL))


'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(sD efaultDestinationPathAndFileNameCELL) = 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(sDefaultSourc ePathAndFileNameCELL))
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(sDefaultDesti nationPathAndFileNameCELL))
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(sD efaultDestinationPathAndFileNameCELL) = sExcelPathAndFileName
Workbooks(ThisWorkbook.Name).Sheets(sMailMergeControllerSheetName).Range(sD efaultSourcePathAndFileNameCELL) = 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(sDefaultSourc ePathAndFileNameCELL))


'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(sD efaultSourcePathAndFileNameCELL) = 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(sDefaultDesti nationPathAndFileNameCELL))


'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(sD efaultDestinationPathAndFileNameCELL) = 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