Cải tiến code (1 người xem)

[alice_nguyen_0401]

Em chào các bạn và các thầy,

Em có 1 đoạn code ở dưới đây. Đoạn code này e sưu tầm được ở trên mạng.
đoạn code này dùng để merge file. Nhưng kết quả sau khi merge xong thì lại nằm trong 1 sheet. Em muốn cải tiến khúc này, để sau khi merge xong thì sẽ tự động save as cho mình thành 1 file xlsx mới nằm trong folder đó luôn. với tên là tên file đầu tiên công với chữ '_merge'. Em ví dụ:
Em có 1 folder là test ở ổ D. ở trong đó có các file a1, a2, a3..... Sau khi merge xong thì trong folder đó sẽ có cho em 1 file là 'a1_merge'.
Việc này giúp em ko phải copy nội dụng sau khi merge xong ra 1 file excel khác. Mong mọi người và các thầy giúp đỡ.

Em xin cám ơn.

Option Explicit


Private Const importedSheet As String = "Imported"  
Private Const combinedSheet As String = "Combined" 
Private importPtr As Long 


Sub main()
    Dim response As Long ' User response
    
    response = MsgBox("Do you want to run the combine process?" & vbCr & _
        "This will erase any previous combined data on the " & combinedSheet & " worksheet", _
        vbYesNoCancel + vbDefaultButton3 + vbQuestion, "Combined Process")
        
    If response = vbYes Then
        Call selectXls ' Sub call
        Call resetDefault ' sub call
    End If
End Sub


Private Sub selectXls()
    Dim thisWb As Workbook ' Executing workbook object
    Dim xlsFiles As Variant ' Multiple .xls path & filename Array
    Dim xls As Variant ' Current .xls path & filename
    Dim xlsCommonSheet As String ' .xls common worksheet name
    Dim startRowCopy As Long ' Row to start copying from
    Dim pastePtr As Long ' Pointer to start pasting from
    
    On Error GoTo genericHandler
    ' Helps speed up process
    Application.EnableCancelKey = False
    Application.Calculation = xlCalculationManual
    
    xlsCommonSheet = Range("Sheet_Name_to_Combine")
    startRowCopy = Range("startRow")
    Set thisWb = ThisWorkbook
    xlsFiles = Application.GetOpenFilename("Micosoft Excel Workbook (*.xlsx), *.xlsx", , _
        "Select file(s) for the combine routine", , True)
    Application.ScreenUpdating = False
    
   
    If IsArray(xlsFiles) Then
        Sheets(combinedSheet).Select
        pastePtr = startRowCopy
        
        'Reset & Clear Data
        importPtr = 0
        thisWb.Sheets(importedSheet).Cells.Clear
        thisWb.Sheets(combinedSheet).Rows(pastePtr & ":" & Application.Rows.Count).Clear
      
        For Each xls In xlsFiles
            If thisWb.FullName <> xls Then
                Call processXls(pastePtr, xls, thisWb, xlsCommonSheet, startRowCopy) 'Sub Call
            End If
        Next xls
        MsgBox "Process Complete", vbInformation + vbOKOnly, "Combined Program"
    End If
    Exit Sub
    
genericHandler: 
    thisWb.Activate
    Call resetDefault
    MsgBox "Error Number: " & Err.Number & vbCr & _
        "Error Description: " & Err.Description, vbInformation + vbOKOnly, "Combined Error Report"
End Sub
Private Sub processXls(ByRef pastePtr As Long, ByVal xls As Variant, _
                       ByVal thisWb As Workbook, _
                       ByVal xlsCommonSheet As String, ByVal startRowCopy As Long)
    Dim openWb As Workbook 
    Dim lastRowx As Long 
    
'    Workbooks.Open (xls) 'Open workbook
    Set openWb = Workbooks.Open(xls)
    
    With openWb.Sheets(xlsCommonSheet)
        .Select
        lastRowx = lastRow()
        If lastRowx > 0 Then
   
            .Rows(startRowCopy & ":" & lastRow).Copy thisWb.Sheets(combinedSheet).Range("A" & pastePtr)
            pastePtr = pastePtr + (lastRowx - startRowCopy) + 1
            
            ' Add to imported
            importPtr = importPtr + 1
            thisWb.Sheets(importedSheet).Range("A" & importPtr) = openWb.Name
        End If
        
    End With
    openWb.Close SaveChanges:=False 'Close workbook
End Sub


Private Function lastRow() As Long
    lastRow = 0
    If WorksheetFunction.CountA(Cells) > 0 Then
        'Search for any entry, by searching backwards by Rows.
        lastRow = Cells.Find(What:="*", After:=[a1], _
              SearchOrder:=xlByRows, _
              SearchDirection:=xlPrevious).Row
    End If
End Function


Private Sub resetDefault()
    ' Sub to reset application screen and calculation
    With Application
        .ScreenUpdating = True
        .EnableCancelKey = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub