Option Explicit
Sub Main_Sub()
'Set THIS Workbook.
Dim wbMe As Workbook
Set wbMe = ThisWorkbook
'Format the top row of the following sheet as the same format that the user will input a date to search through.
Dim shtMe As Worksheet
Set shtMe = wbMe.Sheets("input_forecast")
'"YYYY-MM-DD" (It must be formatted as text to be able to search for it!)
'The format of this has nothing to do with the date they enter being valid or not.
'That's something separate.
shtMe.Rows("1:1").NumberFormat = "@"
'User Inputs the Date (Name of column to copy from in THIS Workbook and to copy into ANOTHER workbook that we open.)
Dim columnHeadingToCopy As String
columnHeadingToCopy = Date_That_Is_The_Column_Heading_Name
Debug.Print columnHeadingToCopy
'The code finds the column number to copy data FROM.
Dim columnNumberFrom_shtMe As Integer
columnNumberFrom_shtMe = Get_Column_Number(columnHeadingToCopy, shtMe.Name, "1:1")
Debug.Print columnNumberFrom_shtMe
If columnNumberFrom_shtMe = 0 Then
MsgBox "Column Heading/Date not found in the SOURCE Worksheet.", vbCritical, "Transfer Aborted"
Exit Sub
End If
'User inputs the desired cell range to copy from THIS Workbook to ANOTHER Workbook.
ReDim rangeAddress(1 To 3) As String
rangeAddress = Cell_Range_To_Copy_From_Date_Column(columnNumberFrom_shtMe)
If rangeAddress(1) = "" Then Exit Sub 'User cancelled.
Debug.Print rangeAddress(1)
'User opens the OTHER Workbook.
Dim file_name As Variant
file_name = Application.GetOpenFilename(Title:="Choose a target Workbook")
Debug.Print file_name
If file_name = False Then Exit Sub 'User cancelled.
'Set THAT Workbook
Dim wbThem As Workbook
Set wbThem = Workbooks.Open(file_name)
'Set THAT Worksheet
Dim shtThem As Worksheet
Set shtThem = wbThem.Sheets("Final")
shtThem.Rows("1:1").NumberFormat = "@"
'The code finds the column number to transfer/paste data TO.
Dim columnNumberFrom_shtThem As Integer
columnNumberFrom_shtThem = Get_Column_Number(columnHeadingToCopy, shtThem.Name, "1:1")
Debug.Print columnNumberFrom_shtThem
If columnNumberFrom_shtThem = 0 Then
MsgBox "Column Heading/Date not found in the DESTINATION Worksheet.", vbCritical, "Transfer Aborted"
Exit Sub
End If
'The code transfers the data BY VALUES ONLY between the two Workbooks.
shtThem.Range(Cells(CInt(rangeAddress(2)), columnNumberFrom_shtThem), Cells(CInt(rangeAddress(3)), columnNumberFrom_shtThem)).Value = shtMe.Range(rangeAddress(1)).Value
End Sub
Function Date_That_Is_The_Column_Heading_Name()
Dim inputbx As String
Try_Again:
inputbx = InputBox("Date, FORMAT; YYYY-MM-DD", "Input Date")
If inputbx = vbNullString Then Exit Function
On Error Resume Next
If Not IsDate(CDate(inputbx)) Then
MsgBox "Please enter a valid date.", vbExclamation, "Notification"
GoTo Try_Again
End If
Date_That_Is_The_Column_Heading_Name = Format(inputbx, "YYYY-MM-DD")
End Function
Sub Test__Function_Get_Column_Number()
MsgBox Get_Column_Number("2020-12-21", ActiveSheet.Name, "1:1")
End Sub
Function Get_Column_Number(columnHeadingToCopy As String, sheetName As String, rangeAddress As String)
On Error GoTo Not_Found:
Get_Column_Number = Application.WorksheetFunction.Match(columnHeadingToCopy, Sheets(sheetName).Range(rangeAddress), 0)
Exit Function
Not_Found:
Get_Column_Number = 0
End Function
Sub Test__Cell_Range_To_Copy_From_Date_Column()
MsgBox Cell_Range_To_Copy_From_Date_Column(3)(1)
End Sub
Function Cell_Range_To_Copy_From_Date_Column(columnNumberToCrossWith As Integer)
Dim inputbx As String
On Error Resume Next
Try_Again:
inputbx = InputBox("Range, FORMAT; " & "row 2 to row 55", "Input Rows to Copy")
If inputbx = vbNullString Then Exit Function
ReDim address(1 To 3) As String
address = Convert_Special_Range_Input(inputbx, columnNumberToCrossWith)
If Range_Is_Valid(address(1)) = False Then
MsgBox "Please enter a range address.", vbExclamation, "Notification"
GoTo Try_Again
End If
Cell_Range_To_Copy_From_Date_Column = address
End Function
Sub Test__Convert_Special_Range_Input()
'This is an array.
'The third argument (3) is the range for the sheet we copy FROM.
'But we keep the top and bottom rows (1) and (2) also for where we PASTE TO.
MsgBox Convert_Special_Range_Input("row 2 to row 55", 3)(1)
MsgBox Convert_Special_Range_Input("row 2 to row 55", 3)(2)
MsgBox Convert_Special_Range_Input("row 2 to row 55", 3)(3)
End Sub
Function Convert_Special_Range_Input(address As String, columnNumberToCrossWith As Integer)
address = Replace(Replace(Replace(UCase(address), " ", ""), "ROW", ""), "TO", ":")
address = Replace(Range(address).address, "$", "")
ReDim addressParts(1 To 3) As String
Dim topRow As Long
topRow = SubString(address, 1, InStr(address, ":") - 1)
addressParts(2) = topRow
If CInt(topRow) < 2 Then
MsgBox "You cannot put in a row < 2. You will override the column headers!", vbCritical, "Tranfer Canceled"
End
End If
Dim bottomRow As Long
bottomRow = SubString(address, InStr(address, ":") + 1, Len(address))
addressParts(3) = bottomRow
addressParts(1) = Range(Cells(topRow, columnNumberToCrossWith), Cells(bottomRow, columnNumberToCrossWith)).address
Convert_Special_Range_Input = addressParts
End Function
Sub Test__SubString()
MsgBox SubString("ABCDEF", 3, 5)
End Sub
Function SubString(inputString As String, Start As Integer, Finish As Integer)
On Error GoTo Quit
SubString = Mid(inputString, Start, Finish - Start + 1)
Quit:
End Function
Sub Test__Range_Is_Valid()
Dim rangeAddress As String
MsgBox Range_Is_Valid("B1:B")
MsgBox Range_Is_Valid("B1:B200")
End Sub
Function Range_Is_Valid(rangeAddress As String)
Range_Is_Valid = True
On Error GoTo Not_Valid
Dim formatt As Variant
Range(rangeAddress).Value = Range(rangeAddress).Value
Exit Function
Not_Valid:
Range_Is_Valid = False
End Function
