• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Need code to paste the copied range by matching the header (month and year) of Input source

J

jexcel j

New Member
Hi Everyone....good to be part of this great coding world. I am a beginer and learning from this pool of genius peoples.
I have one Master File (attached) where I already have one code to pull worksheets from one folder and select the desired range to copy and paste in the Master File.

Now I want to match the Year & Month of Input file and paste the data exactly below the same year in Master file.

I am not able to paste the data by matching the Month and year of Input File and Master file.....

Your help and guidence is highly appreciated :)

below is the current code

Code: 
Sub Button1_Click()

 
'Last cell in column
Dim sd As Worksheet, rd As Range, ws As Worksheet
Set sd = ThisWorkbook.Sheets("Master")
Set rd = sd.Range("B5:AE25")
 
Dim LastCell As Range
Dim LastCellRowNumber As Long
 
Set ws = Worksheets("Master")
 
With ws
    Set LastCell = .Cells(.Rows.Count, "I").End(xlUp)
    LastCellRowNumber = LastCell.Row + 1
End With
 
Dim wb As Workbook
Dim vFile As Variant
 
'Set source workbook
Set wb = ActiveWorkbook
 
'Open the target workbook
vFile = Application.GetOpenFilename("Excel-files,*.xlsm", _
    1, "Select One File To Open", , False)
 
'if the user didn't select a file, exit sub
If TypeName(vFile) = "Boolean" Then Exit Sub
Workbooks.Open vFile
 
Set wb = ActiveWorkbook
 
'Select cells to copy
wb.Worksheets("Input Data").Select
wb.Worksheets("Input Data").Range("B5:AE25").Select
Selection.Copy
 
'Go back to original workbook you want to paste into
 
sd.Activate
 
'Paste starting at the last empty row
 
sd.Range("I" & LastCellRowNumber).Select
Selection.PasteSpecial xlPasteValues
 
End Sub
 

Attachments

  • Input File.xlsm
    22.3 KB · Views: 0
  • Master File.xlsm
    21 KB · Views: 1
Hi jexcel j, and welcome to the forum!

I wasn't sure if you needed the formatting copied over or not, but give this a try:
Code: 
Sub Button1_Click()

Dim wbSource As Workbook
Dim wbDest As Workbook
Dim fCell As Range
Dim fVal As Date
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim vFile As Variant
Dim lastCol As Long

Set wbDest = ThisWorkbook
Set wsDest = wbDest.Worksheets("Master")

Application.ScreenUpdating = False

'Open the target workbook
vFile = Application.GetOpenFilename("Excel-files,*.xlsm", _
    1, "Select One File To Open", , False)

'if the user didn't select a file, exit sub
If TypeName(vFile) = "Boolean" Then Exit Sub
Workbooks.Open vFile

Set wbSource = ActiveWorkbook
Set wsSource = wbSource.Worksheets("Input Data")

'Find where to paste new data
fVal = wsSource.Range("C4").Value

Set fCell = wsDest.Range("3:3").Find(what:=fVal, LookIn:=xlFormulas, lookat:=xlWhole)

If fCell Is Nothing Then
    MsgBox "Date not found, please correct Master sheet"
    Exit Sub
End If

With wsSource
    'Find the last column of data
    lastCol = .Cells(4, .Columns.Count).End(xlToLeft).Column
   
    'Note that none of these copy over formatting. Used original code as a guide
    'Copy headings
    wsSource.Range("B5:B25").Copy
    wsDest.Range("A4").PasteSpecial xlPasteValuesAndNumberFormats
   
    'Copy data below correct data
    wsSource.Range("C5", .Cells(25, lastCol)).Copy
    fCell.Offset(1).PasteSpecial xlPasteValuesAndNumberFormats
End With
Application.CutCopyMode = False
'Close input file, don't save any changes
wbSource.Close False

Application.ScreenUpdating = True

End Sub
 
Luke M said:
Hi jexcel j, and welcome to the forum!

I wasn't sure if you needed the formatting copied over or not, but give this a try:
Code: 
Sub Button1_Click()
 
Dim wbSource As Workbook
Dim wbDest As Workbook
Dim fCell As Range
Dim fVal As Date
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim vFile As Variant
Dim lastCol As Long
 
Set wbDest = ThisWorkbook
Set wsDest = wbDest.Worksheets("Master")
 
Application.ScreenUpdating = False
 
'Open the target workbook
vFile = Application.GetOpenFilename("Excel-files,*.xlsm", _
    1, "Select One File To Open", , False)
 
'if the user didn't select a file, exit sub
If TypeName(vFile) = "Boolean" Then Exit Sub
Workbooks.Open vFile
 
Set wbSource = ActiveWorkbook
Set wsSource = wbSource.Worksheets("Input Data")
 
'Find where to paste new data
fVal = wsSource.Range("C4").Value
 
Set fCell = wsDest.Range("3:3").Find(what:=fVal, LookIn:=xlFormulas, lookat:=xlWhole)
 
If fCell Is Nothing Then
    MsgBox "Date not found, please correct Master sheet"
    Exit Sub
End If
 
With wsSource
    'Find the last column of data
    lastCol = .Cells(4, .Columns.Count).End(xlToLeft).Column
  
    'Note that none of these copy over formatting. Used original code as a guide
    'Copy headings
    wsSource.Range("B5:B25").Copy
    wsDest.Range("A4").PasteSpecial xlPasteValuesAndNumberFormats
  
    'Copy data below correct data
    wsSource.Range("C5", .Cells(25, lastCol)).Copy
    fCell.Offset(1).PasteSpecial xlPasteValuesAndNumberFormats
End With
Application.CutCopyMode = False
'Close input file, don't save any changes
wbSource.Close False
 
Application.ScreenUpdating = True
 
End Sub
Click to expand...


Thank You Very Much Luke M

Yes formatting is required but values will do for me.....just a small addtion or updation if possible.....

There are almost 200 Input files with different names which I have to pull in the master sheet. The structure of the data is exactly similar in all files...even the tab name i.e. 'Input Data' is uniqe in all files.

so the requirement is :-
- I will place all the 200 files in one folder (all have uniqe fields and similar structure)
- Macro needs to be triggered from Master File
- Macro should open one by one file from the folder and copy the input data range and paste in Master file one below the other by matching the month and year
- Macro should also take the name of the file and paste in the first row of 'File Name' column

If above req is critical or complex then a simple addtion in above code to paste next copied data below blank row of 'Headings' column will do for me

i have attached the Master file with how the results shoud show as example

many many thanks !!!
 

Attachments

  • Master File.xlsm
    30.8 KB · Views: 1
  • Input File 1.xlsm
    22.3 KB · Views: 1
  • Input File 2.xlsm
    22.3 KB · Views: 1
Can do. We'll use one macro to loop over the files, and it will call the macro that does our work. See attached.
 

Attachments

  • Master File LM2.xlsm
    23.7 KB · Views: 2
Luke M said:
Can do. We'll use one macro to loop over the files, and it will call the macro that does our work. See attached.
Click to expand...
Excellent !!! very happy with the results....this is what exactly the requirement.....really admire you Luke.....thanks a ton....and Thanks Chandoo.org for provding the oportunity....

small tweak needed - where to put the "UpdateLinks :=False " to stop getting the Link update popup
 
In the InputDump macro, change this
Code: 
Set wbSource = Workbooks.Open(fName)
to this
Code: 
Set wbSource = Workbooks.Open(fileName:=fName, UpdateLinks:=False)
 
Thanks a Lot Luke M.....was a bit busy and stuck with another priorities...your solutions have saved a lot of time for me....thanks again
 
You must log in or register to reply here.
Back
Top