thang_nguyen1
Thành viên hoạt động
- Tham gia
- 6/10/16
- Bài viết
- 136
- Được thích
- 8
Mình có một đoạn code về gộp File. Giờ mình muốn sửa sao cho khi gộp file chỉ lấy tiêu đề ở file thứ nhất thôi, từ file thứ hai sẽ bỏ qua tiều đề. Mong mọi người giúp đỡ mình, xin cảm ơn mọi người.
Mã:
Sub MergeSheetInFolder()
Dim objFs As Object
Dim objFolder As Object
Dim File As Object
Dim Wb As Workbook
Dim ws As Worksheet
Dim OpenWb As Workbook
Dim OpenWs As Worksheet
Dim xDir As String
Dim Folder As Object
Dim xRows As Long
Dim xColumns As Long
Dim xColumnsFirst As Long
Dim WorkRng As Range
Dim xTitleId As String
Dim LastRowWb As Long
Dim LastRowOpenWb As Long
On Error Resume Next
Set Wb = ActiveWorkbook
Set ws = Wb.ActiveSheet
xTitleId = "Vung merge"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Xin chon vung (1 sheet trong file nay) de paste data", xTitleId, WorkRng.Address, Type:=8)
LastRowWb = ws.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
If LastRowWb = 0 Then
LastRowWb = 1
Else
LastRowWb = LastRowWb + 1
End If
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.DisplayStatusBar = False
.DisplayAlerts = False
.EnableEvents = False
End With
Set Folder = Application.FileDialog(msoFileDialogFolderPicker)
If Folder.Show <> -1 Then
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.DisplayStatusBar = True
.DisplayAlerts = True
.EnableEvents = True
End With
Exit Sub
End If
xDir = Folder.SelectedItems(1)
Set objFs = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFs.GetFolder(xDir)
For Each File In objFolder.Files
Set OpenWb = Workbooks.Open(File.path, True, True)
Set OpenWs = OpenWb.ActiveSheet
LastRowOpenWb = OpenWs.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
OpenWs.Rows("1:" & LastRowOpenWb).Copy
Wb.Activate
With ActiveSheet.Range("a" & LastRowWb)
.PasteSpecial xlPasteAll
.PasteSpecial xlPasteFormats
End With
LastRowWb = LastRowWb + LastRowOpenWb
OpenWb.Close False
Set OpenWb = Nothing
Next
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.DisplayStatusBar = True
.DisplayAlerts = True
.EnableEvents = True
.CutCopyMode = False
End With
MsgBox "Done!"
End Sub
