Copy pasting files as values

[Sarvottam]

Hi

I am looking for macro which will open all the files in specified folder and copy all the data from active sheet paste it as values in same sheet . Save the file and close file.

Note : Number of files saved in folder may vary in future.

Opens each Excel file within the user-selected folder
Copy paste data as values . – (Active sheet)
Saves the file
Closes the workbook

Thank you.

 

[Johnny C]

Something along these lines. You need to give the worksheet a name in VBA properties, in this case it's called wksSupplier,
there are some ranges you need to create

Range "SuppSheetName" - the name of the sheet in the files you open or change Range("SuppSheetName").Value to ActiveSheet
Range "SuppSheetFile" - A template for the names of the worksheets e.g. "Book", make the value blank cheers if you want all
Range "RowOne" - the number of the first row to copy data to. Must be 1 or more

This picks up data from particular cells, you'll need to change that to pick up the data you want and paste it accordingly into the target sheet.

Hopefully it's enough to get you started, the comments should help you

Option Explicit
Sub ScanFiles()
Dim X
Dim strPath$, strFile$, strSuppName$, strThisFile$, strExt$, strTargetSheet$, strSuppFile$, strSuppID$
Dim strError$
Dim sglSuppAve!, intRedCount%, intRowCount%, intRowCountOriginal%
Dim wbTarget As Workbook, wbThisWB As Workbook
Dim FldrPicker As FileDialog


'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.AskToUpdateLinks = False

strThisFile = ActiveWorkbook.Name
strTargetSheet = wksSupplier.Range("SuppSheetName").Value
strSuppFile = wksSupplier.Range("SuppSheetFile").Value
intRowCount = wksSupplier.Range("RowOne").Value
intRowCountOriginal = wksSupplier.Range("RowOne").Value


'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

With FldrPicker
    .Title = "Select A Target Folder"
    .AllowMultiSelect = False
    If .Show <> -1 Then
        Application.EnableEvents = True
        Application.ScreenUpdating = True
        Application.AskToUpdateLinks = True
        MsgBox "No folder chosen"
        Exit Sub
    End If
    strPath = .SelectedItems(1) & "\"
End With
  
strPath = strPath
If strPath = "" Then
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.AskToUpdateLinks = True
    MsgBox "No folder chosen"
    Exit Sub
End If


'Target File Extension (must include wildcard "*")
strExt = strSuppFile & "*.xls*"
strFile = Dir(strPath & strExt)
Set wbThisWB = ActiveWorkbook

On Error Resume Next
wksSupplier.Range("Data").ClearContents
On Error GoTo 0

'Loop through each Excel file in folder
Do While strFile <> ""
    'Set variable equal to opened workbook
    If strFile <> strThisFile Then
        Set wbTarget = Workbooks.Open(Filename:=strPath & strFile)
        If UCase(Left(strFile, Len(strSuppFile))) = UCase(strSuppFile) Then
            strSuppID = Mid(strFile, Len(strSuppFile) + 1, InStrRev(strFile, ".") - Len(strSuppFile) - 1)
            'Ensure Workbook has opened before moving on to next line of code
            DoEvents
            
            'Get information from target workbook
            On Error Resume Next
            Sheets(strTargetSheet).Activate
            If Err.Number <> 0 Then
                On Error GoTo 0
                strSuppName = "Not known"
                sglSuppAve = 0
                intRedCount = 0
                strError = "Can't find sheet [" & strTargetSheet & "] in " & strFile
            Else:
                On Error GoTo 0
                strSuppName = Cells(2, 3).Value
                sglSuppAve = Cells(4, 3).Value
                intRedCount = Cells(6, 3).Value
                strError = ""
            End If
                    
            'Paste into this workbook
            wbThisWB.Activate
            Sheets("Summary").Activate
            
            Cells(intRowCount, 2).Value = strSuppName
            Cells(intRowCount, 3).Value = sglSuppAve
            Cells(intRowCount, 4).Value = intRedCount
            Cells(intRowCount, 5).Value = strError
            Application.ScreenUpdating = True
            DoEvents
            Application.ScreenUpdating = False
            intRowCount = intRowCount + 1
        End If
        'Save and Close Workbook
          wbTarget.Close SaveChanges:=False
          
        'Ensure Workbook has closed before moving on to next line of code
          DoEvents
    
        'Get next file name
    End If
    strFile = Dir
Loop


'reset system flags
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.AskToUpdateLinks = True
Application.Calculation = xlCalculationAutomatic
Application.CutCopyMode = False

'Message Box when tasks are completed
If intRowCount <> intRowCountOriginal Then
    MsgBox "All done " & (intRowCount - wksSupplier.Range("RowOne").Value) & " files processed"
Else
    MsgBox "Couldnot find any files in the folder you chose"
End If
Cells(wksSupplier.Range("RowOne").Value, 3).Select

End Sub

 

[Sarvottam]

Hi ,

Thank for the code ..
But I am sorry it is not getting this macro correctly .


I have many excel files which are named indiviualy and saved in one folder. I want macro to open file and copy and paste details in active sheet which is named as "RECAP" sheet in all the excels as values save file and close file .