PDA

View Full Version : [SOLVED] VBA code copy and paste



lai ling
12-25-2018, 08:25 PM
Hi everyone, need help! I have the codes below. The codes copy certain data from all files in a folder into a new worksheet. Need your help to change the code to PASTE AS VALUE instead. Thank you in advance!

Sub Merge2MultiSheets_test()
Dim xRg As Range
Dim xSelItem As Variant
Dim xFileDlg As FileDialog
Dim xFileName, xSheetName, xRgStr As String
Dim xBook, xWorkBook As Workbook
Dim xSheet As Worksheet
On Error Resume Next
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False

xSheetName = "test" 'which worksheet you are copying from. Pls amend accordingly
xRgStr = "a1:n10" 'cells you are copying from. Pls amend accordingly

Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
With xFileDlg
If .Show = -1 Then
xSelItem = .SelectedItems.Item(1)
Set xWorkBook = ThisWorkbook

Set xSheet = xWorkBook.Sheets("test") 'where are you copying to. Pls amend accordingly

If xSheet Is Nothing Then
xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.Count )).Name = "New Sheet"
Set xSheet = xWorkBook.Sheets("New Sheet")
End If
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
If xFileName = "" Then Exit Sub
Do Until xFileName = ""
Set xBook = Workbooks.Open(xSelItem & "" & xFileName)
Set xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
xFileName = Dir()
xBook.Close
Loop
End If
End With
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

大灰狼1976
12-25-2018, 08:45 PM
Hi lai ling!
you can use the [#] icon to add them and paste your macro between them.

Sub Merge2MultiSheets_test()
Dim xRg As Range
Dim xSelItem As Variant
Dim xFileDlg As FileDialog
Dim xFileName, xSheetName, xRgStr As String
Dim xBook, xWorkBook As Workbook
Dim xSheet As Worksheet
On Error Resume Next
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
xSheetName = "test" 'which worksheet you are copying from. Pls amend accordingly
xRgStr = "a1:n10" 'cells you are copying from. Pls amend accordingly
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
With xFileDlg
If .Show = -1 Then
xSelItem = .SelectedItems.Item(1)
Set xWorkBook = ThisWorkbook
Set xSheet = xWorkBook.Sheets("test") 'where are you copying to. Pls amend accordingly
If xSheet Is Nothing Then
xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.Count )).Name = "New Sheet"
Set xSheet = xWorkBook.Sheets("New Sheet")
End If
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
If xFileName = "" Then Exit Sub
Do Until xFileName = ""
Set xBook = Workbooks.Open(xSelItem & "" & xFileName)
Set xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
xRg.Copy
xSheet.Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
xFileName = Dir()
xBook.Close
Loop
End If
End With
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

lai ling
12-25-2018, 09:22 PM
Thanks so much!

大灰狼1976
12-25-2018, 09:44 PM
Hi lai ling!
If the problem is solved, please mark the thread as [Solved].
Thread Tools (on the top right corner, above the first message):)