How to paste a selected range of data into a spreadsheet with the same column name as we chose earlier in inputbx

Palucci

Banned user
Joined
Sep 15, 2021
Messages
138
Office Version
  1. 365
Platform
  1. Windows
Hello Guys !

I have a macro that uses inputbox to search for a column name (it's a data) and select a range of data from that column. I would like it to paste this range into a second file into a column with the same name in the range I indicated. However, I don't know exactly how to do it, Do you have some suggestions.
Below is my code:

Rich (BB code):
Dim vDate As Date
Dim wbMe As Workbook
Dim data_wb As Workbook
Dim ws As Worksheet
Dim inputbx As String

'Set workbook' '
Set wbMe = ThisWorkbook
wbMe.Sheets("input_forecast").Rows("1:1").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.NumberFormat = "YYYY-MM-DD"
    
'Open file
Set wbMe = ThisWorkbook
file_name = Application.GetOpenFilename(Title:="Choose a target Workbook")
If file_name <> False Then

   'Set data file
   Set data_wb = Application.Workbooks.Open(file_name)
   
   'paste copy like value and change to date format'
   data_wb.Sheets("Final").Rows("1:1").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.NumberFormat = "YYYY-MM-DD"
    'set our ws'
   Set ws = data_wb.Sheets("Final")
    
    
''' Put date input box  '''
    Do
        inputbx = InputBox("Date, FORMAT; YYYY-MM-DD")
        If inputbx = vbNullString Then Exit Sub
        On Error Resume Next
        vDate = CDate(inputbx)
        On Error GoTo 0
        DateIsValid = IsDate(vDate)
        If Not DateIsValid Then MsgBox "Please enter a valid date.", vbExclamation
    Loop Until DateIsValid
'COPY loop"
    Dim loc As Range, lc As Long
    With data_wb.Sheets("Final")
        Set loc = .Cells.Find(what:=Format(inputbx, "YYYY-MM-DD"))
        If Not loc Is Nothing Then
            lc = .Cells(loc.Row, Columns.Count).End(xlToLeft).Column
            .Range(.Cells(109, loc.Column), .Cells(123, lc)).Copy
        End If
    End With
 

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.
This was fun:
  • Copies from a sheet named "input_forecast" in the SOURCE (ThisWorkbook) to a sheet named "Final" in the destination Workbook.
  • I just recorded a video and will be uploading to show how it works, but I believe this is what you were trying to do.
VBA Code:
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
 
Upvote 0
Solution
Really thanks you for your code. that we didn't get along here. I need to copy a range from Final to input_forecast.
 
Upvote 0
Really thanks you for your code. that we didn't get along here. I need to copy a range from Final to input_forecast.
Then put the text "Final" where "input_forecast" is and "input_forecast" where "Final" is in the code. Also, put the code in the Workbook that contains the "Final" sheet instead of in the Workbook that contains the "input_forecast" sheet. (And run it from the Workbook that contains "Final" instead.) That should fix it.
 
Upvote 0
@Palucci, I see you already have a solution, but still wanted to let you know that you were on the right track. You were searching for text instead of a date. After that change and some cosmetic tweaks, your code will look like this.

VBA Code:
Sub palucci()

    ' I have a macro that uses inputbox to search for a column name (it's a data) and select a range of data from that column.
    ' I would like it to paste this range into a second file into a column with the same name in the range I indicated.
    ' However, I don't know exactly how to do it, Do you have some suggestions.

    '  I need to copy a range from Final to input_forecast.

    Dim vDate           As Date
    Dim wsDestination   As Worksheet
    Dim wsSource        As Worksheet
    Dim inputbx         As String
    Dim DateIsValid     As Boolean
    Dim FullNameToOpen  As Variant

    Set wsDestination = ThisWorkbook.Sheets("input_forecast")
    ConvertFirstRowToDate wsDestination

    FullNameToOpen = Application.GetOpenFilename(Title:="Choose a target Workbook")
    If Not VarType(FullNameToOpen) = vbBoolean Then

        'Set data file
        Set wsSource = Application.Workbooks.Open(FullNameToOpen).Sheets("Final")

        'paste copy like value and change to date format'
        ConvertFirstRowToDate wsSource

        ''' Put date input box  '''
        Do
            inputbx = InputBox("Date, FORMAT; YYYY-MM-DD")
            If inputbx = vbNullString Then Exit Sub
            On Error Resume Next
            vDate = CDate(inputbx)
            On Error GoTo 0
            DateIsValid = IsDate(vDate)
            If Not DateIsValid Then MsgBox "Please enter a valid date.", vbExclamation
        Loop Until DateIsValid

        'COPY loop"
        Dim locSource As Range, lc As Long
        Dim locDest   As Range

        Set locSource = wsSource.Rows("1:1").Find(What:=vDate)
        Set locDest = wsDestination.Rows("1:1").Find(What:=vDate)

        If Not locDest Is Nothing Then
            If Not locSource Is Nothing Then
                With wsSource
                    lc = .Cells(locSource.Row, .Columns.Count).End(xlToLeft).Column
                    .Range(.Cells(109, locSource.Column), .Cells(123, lc)).Copy
                    locDest.Offset(1).PasteSpecial xlPasteAll
                    Application.CutCopyMode = False
                End With
            End If
        End If
    End If
End Sub

Public Sub ConvertFirstRowToDate(ByVal argSht As Worksheet)
    With argSht.Rows("1:1")
        .Copy
        .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        .NumberFormat = "YYYY-MM-DD"
    End With
    Application.CutCopyMode = False
End Sub
 
Upvote 0

Forum statistics

Threads
1,224,583
Messages
6,179,673
Members
452,937
Latest member
Bhg1984

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