Macro to open up Multiple Files and Paste Special values retaining formts

[howard]

I have a macro to open up several files and to copy and paste the data

I need the macro amended, so that the data is pasted as values but the original format from the source data is retained

It would be appreciated if someone could kindly amend my code to incorporate this

 Sub Open_MultipleFiles()
ChDir "C:\My documents"
Dim LR As Long

With Sheets("Imported Data")
LR = .Cells(.Rows.Count, "B").End(xlUp).Row
Range("B2:B" & LR).ClearContents

Dim fDialog As Object, varFile As Variant
Dim nb As Workbook, tw As Workbook, ts As Worksheet
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.CutCopyMode = False
End With
Set tw = ThisWorkbook
Set ts = tw.ActiveSheet
Set fDialog = Application.FileDialog(3)
ChDir "C:\my Documents"
With fDialog
.Filters.Clear
.Filters.Add "Excel files", "*.xlsm*"
.Show

For Each varFile In .SelectedItems
Set nb = Workbooks.Open(Filename:=varFile, local:=True)
nb.Sheets("Pivot Table").Range("A5:K5").Copy Destination:=ThisWorkbook.Sheets("Imported Data").Range("B" & Rows.Count).End(xlUp).Offset(1)
nb.Close False
Next
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.CutCopyMode = True
End With

 End With
   End Sub

 

[JLGWhiz]

Change this

nb.Sheets("Pivot Table").Range("A5:K5").Copy Destination:=ThisWorkbook.Sheets("Imported Data").Range("B" & Rows.Count).End(xlUp).Offset(1)

To this

nb.Sheets("Pivot Table").Range("A5:K5").Copy 
ThisWorkbook.Sheets("Imported Data").Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValuesAndNumberFormats
ThisWorkbook.Sheets("Imported Data").Range("B" & Rows.Count).End(xlUp).PasteSpecial xlPasteFormats

 

[howard]

Thanks for the help, much appreciated

 

[JLGWhiz]

Thanks for the help, much appreciated

You're welcome,
regards, JLG