Copy and Paste

[jmk15315]

Good Evening,

I am currently using a spreadsheet that I did not write the vba code for a certain function, but hoping someone might be able to rtell me if the possibility exists to have it function slightly different.

I have a tab in the workbook that there is a current macro that will retrieve the information from a different spreadsheet (selected by the user) and copy data from a named range of cells, then paste it into the current spreadsheet.

I am wondering if there is a way to select multiple spreadsheets so the operation can happen all at once?

The information from the "Retrieved from" sheets will always reside in the same sub folder.

Public Sub LinkComposite()
  Dim wbSource As Workbook, wsSource As Worksheet, wsComposite As Worksheet
  Dim sSource As String, sComposite As String, iDataRow As Long, rFound As Range
 
  sComposite = ActiveWorkbook.Name
  If ActiveCell.Column <> 1 Then
    MsgBox "Please ensure the selected cell is after the header row and in column A", , "Incorrect Cell Selected"
    Exit Sub
  End If
  Set rFound = ThisWorkbook.Worksheets("Tooling").Range("B:B").Find("FREEFORM / SWAG", LookIn:=xlValues)
  If ActiveCell.Row > 2 And ActiveCell.Row < rFound.Row Then
    iDataRow = ActiveCell.Row
  Else
    MsgBox "Please ensure the selected cell is between the header row and the FREEFORM / SWAG Row" _
       & " and in column A", , "Incorrect Cell Selected"
    Exit Sub
  End If
  Application.Dialogs(xlDialogOpen).Show (ActiveWorkbook.Path)
 
  sSource = ActiveWorkbook.Name

  Set wbSource = Workbooks(sSource)
  Set wsSource = wbSource.Worksheets("Summary")
  Set wsComposite = ThisWorkbook.Worksheets("Tooling")
 
  With wsComposite
    wsSource.Range("Accounting_Info").Copy
    .Range("A" & iDataRow & ":M" & iDataRow).PasteSpecial xlPasteValues
   
  End With
 
  Windows(sComposite).Activate
  wbSource.Close SaveChanges:=False
 
  Range("A2").Select
 
  End Sub

The user selects the file to import data from, I am hoping that there is a way to allow for the selection of multiple files in order to save time. There are instances where the user needs to import 30 or more sets of data and this would cut down on the time to complete the task. Obviously I would want the information to come in from each spreadsheet and populate in there each rows. This might not even be possible, but hoping someone might be able to assist me with this.

 

[Anthony47]

You might try by replacing from line Application.Dialogs(xlDialogOpen).Show (ActiveWorkbook.Path) till End Sub with the following code:

Dim fNames() As String
ReDim fNames(1 To 100)
    'Scelta dell'immagine
    With Application.FileDialog(msoFileDialogFilePicker)
                .Title = "Scegli l'Immagine da inserire"
                .InitialFileName = ActiveWorkbook.Path
                .AllowMultiSelect = True
                .Filters.Clear
                .Filters.Add "Excel", "*.xls*"
       .Show
        If .SelectedItems.Count = 0 Then
            MsgBox ("No selection, process is aborted")
            Exit Sub
        End If
        For I = 1 To .SelectedItems.Count
            fNames(I) = .SelectedItems(I)
        Next I
        ReDim Preserve fNames(1 To I - 1)
    End With
'
For I = 1 To UBound(fNames)
    sSource = ActiveWorkbook.Name
    Set wbSource = Workbooks(sSource)
    Set wsSource = wbSource.Worksheets("Summary")
    Set wsComposite = ThisWorkbook.Worksheets("Tooling")
   
    With wsComposite
       wsSource.Range("Accounting_Info").Copy
       .Range("A" & iDataRow & ":M" & iDataRow).PasteSpecial xlPasteValues
    End With
   
    Windows(sComposite).Activate
    wbSource.Close SaveChanges:=False
Next I

ThisWorkbook.Activate
Range("A2").Select
 
End Sub

Please test it carefully ON A COPY of your workbook

 

[jmk15315]

Thank you for your suggestion. It does not execute and returns the following error

Here is an updated copy of the code with your suggestion inserted. I made a copy of the file and am using it in my "sandbox" so as to not affect the copy in use by my department.

Public Sub LinkComposite()
  Dim wbSource As Workbook, wsSource As Worksheet, wsComposite As Worksheet
  Dim sSource As String, sComposite As String, iDataRow As Long, rFound As Range
  'sSrcPath As String - Removed this declaration as it is not being used - SRB 06052019
  
  sComposite = ActiveWorkbook.Name
  If ActiveCell.Column <> 1 Then
    MsgBox "Please ensure the selected cell is after the header row and in column A", , "Incorrect Cell Selected"
    Exit Sub
  End If
  Set rFound = ThisWorkbook.Worksheets("Tooling").Range("B:B").Find("FREEFORM / SWAG", LookIn:=xlValues)
  If ActiveCell.Row > 2 And ActiveCell.Row < rFound.Row Then
    iDataRow = ActiveCell.Row
  Else
    MsgBox "Please ensure the selected cell is between the header row and the FREEFORM / SWAG Row" _
       & " and in column A", , "Incorrect Cell Selected"
    Exit Sub
  End If

' NEW CODE FOR MULTIPLE FILE SELECTIONS

'  Application.Dialogs(xlDialogOpen).Show (ActiveWorkbook.Path)
  
'  sSource = ActiveWorkbook.Name
'  Set wbSource = Workbooks(sSource)
'  Set wsSource = wbSource.Worksheets("Summary")
'  Set wsComposite = ThisWorkbook.Worksheets("Tooling")
'
'  With wsComposite
'    wsSource.Range("Accounting_Info").Copy
'    .Range("A" & iDataRow & ":M" & iDataRow).PasteSpecial xlPasteValues
'
'  End With
'
'  Windows(sComposite).Activate
'  wbSource.Close SaveChanges:=False
'
'  Range("A2").Select
  
Dim fNames() As String
ReDim fNames(1 To 100)
    'Scelta dell'immagine
    With Application.FileDialog(msoFileDialogFilePicker)
                .Title = "Scegli l'Immagine da inserire"
                .InitialFileName = ActiveWorkbook.Path
                .AllowMultiSelect = True
                .Filters.Clear
                .Filters.Add "Excel", "*.xls*"
       .Show
        If .SelectedItems.Count = 0 Then
            MsgBox ("No selection, process is aborted")
            Exit Sub
        End If
        For I = 1 To .SelectedItems.Count
            fNames(I) = .SelectedItems(I)
        Next I
        ReDim Preserve fNames(1 To I - 1)
    End With
'
For I = 1 To UBound(fNames)
    sSource = ActiveWorkbook.Name
    Set wbSource = Workbooks(sSource)
    Set wsSource = wbSource.Worksheets("Summary")
    Set wsComposite = ThisWorkbook.Worksheets("Tooling")
   
    With wsComposite
       wsSource.Range("Accounting_Info").Copy
       .Range("A" & iDataRow & ":M" & iDataRow).PasteSpecial xlPasteValues
    End With
   
    Windows(sComposite).Activate
    wbSource.Close SaveChanges:=False
Next I

ThisWorkbook.Activate
Range("A2").Select
 
End Sub

 

[Anthony47]

Is any instruction highlighted when the error is shown?

 

[jmk15315]

Sorry, yes. The "I" in the "For I = 1 To .SelectedItems.Count" statement

 

[Anthony47]

Hummm.... Did you copy the code from the post and pasted it into the vba module? (or did you retype it)
Let's try declaring I as a type long variable
But I realized my code miss the crucial "Open the Workbook" command! as well as there a couple of cosmetics errors in the text

So try modifying the code as follows:

Dim fNames() As String, I As Long                       '+++ I as Long added
ReDim fNames(1 To 100)
    'Select files                                       '... Modified comment
    With Application.FileDialog(msoFileDialogFilePicker)
                .Title = "Select file(s)"               '... Modified text
                .InitialFileName = ActiveWorkbook.Path
                .AllowMultiSelect = True
                .Filters.Clear
                .Filters.Add "Excel", "*.xls*"
       .Show
        If .SelectedItems.Count = 0 Then
            MsgBox ("No selection, process is aborted")
            Exit Sub
        End If
        For I = 1 To .SelectedItems.Count
            fNames(I) = .SelectedItems(I)
        Next I
        ReDim Preserve fNames(1 To I - 1)
    End With
'
For I = 1 To UBound(fNames)
    Workbooks.Open Filename:=fNames(I), ReadOnly:=True   '+++ ADD THIS LINE
    sSource = ActiveWorkbook.Name

+++ identifies the addictions
... identifies cosmetics changes

 

[jmk15315]

I did a Copy/Paste of your code.

I will do the same here and let you know the results.

 

[jmk15315]

It made it through the selection of files without error, but it overwrote with each new file import. It did not shift to the next row after each new file was copied in.

 

[Anthony47]

Add the Debug.Print line in this position:

For I = 1 To UBound(fNames)
    Workbooks.Open Filename:=fNames(I), ReadOnly:=True   '!!! ADD THIS LINE
    sSource = ActiveWorkbook.Name
    Debug.Print I, sSource
    Set wbSource = Workbooks(sSource)

Then run the test selecting 5 files; at the end go to the vba, open the "Immediate Window" (typing Contr-g should do the job, or Menu /View /Immediate window); copy the content of the window and insert it in the next message. The log should tell us which files were processed

EDIT: Forget about this message, I misunderstood your point

 

[Anthony47]

No no, forget about debug.print (I misunderstoot your point)

The position where you paste the copied rang is driven by "iDataRow"; but I can't understand how you determine its value, which is the rule I mean
But try modifying this line .Range("A" & iDataRow & ":M" & iDataRow).PasteSpecial xlPasteValues to

.Range("A" & (iDataRow+I-1) & ":M" & (iDataRow+I-1)).PasteSpecial xlPasteValues