Option Explicit
Sub Copy_Paste3()
Dim wb As Workbook
Dim objFileDLG As Office.FileDialog
Dim strFilePath, lcTargetCell
Dim intSrcRows As Integer
Dim intTgtRows As Integer
ChDir "D:\Data\"
Set objFileDLG = Application.FileDialog(msoFileDialogFilePicker)
Dim copyRange As Range
intTgtRows = 2
Do While True
strFilePath = ""
With objFileDLG
.Filters.Add "Excel Files", "*.xls", 1
.FilterIndex = 1
.AllowMultiSelect = False
.Title = "Select The Workbook to copy From "
If .Show() <> 0 Then
strFilePath = .SelectedItems(1)
End If
End With
If Trim(strFilePath) = "" Then Exit Do
Set wb = Workbooks.Open(strFilePath)
intSrcRows = wb.Worksheets(1).Cells(Cells.Rows.Count, "A").End(xlUp).Row
Set copyRange = wb.Worksheets(1).Range("B6:B" & intSrcRows)
Set copyRange = Union(copyRange, copyRange.Offset(, 4), copyRange.Offset(, 6).Resize(, 6))
copyRange.Copy
Set lcTargetCell = ThisWorkbook.Worksheets(2).Range("A" & Rows.Count).End(xlUp).Offset(1)
lcTargetCell.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
ThisWorkbook.Worksheets(2).Range("B:B").NumberFormat = "dd-mmm"
Application.CutCopyMode = False
wb.Close
Set wb = Nothing
intTgtRows = intTgtRows + intSrcRows - 1
Loop
'new lines
On Error Resume Next
ThisWorkbook.Worksheets(1).Columns(1).SpecialCells(xlBlanks).EntireRow.Delete
End Sub
|