Sau khi gộp file bị mất chữ kí và logo công ty

Liên hệ QC
Tôi tuân thủ nội quy khi đăng bài

Thaolp1987

Thành viên mới
Tham gia
8/9/23
Bài viết
1
Được thích
0
Dear các anh chị, vui lòng xem giùm em cái code gộp file dưới đây. Trước em vẫn dùng bình thường để gộp các file báo cáo có chữ kí, gần đây sau khi gộp file tất cả picture bị mất. Em cảm ơn!
Sub CHOOSE_FILE()
Dim fnameList, fnameCurFile As Variant
Dim countFiles, countSheets As Integer
Dim wksCurSheet As Worksheet
Dim wbkCurBook, wbkSrcBook As Workbook

fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)

If (vbBoolean <> VarType(fnameList)) Then

If (UBound(fnameList) > 0) Then
countFiles = 0
countSheets = 0

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set wbkCurBook = ActiveWorkbook

For Each fnameCurFile In fnameList
countFiles = countFiles + 1

Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)

For Each wksCurSheet In wbkSrcBook.Sheets
countSheets = countSheets + 1
wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
Next

wbkSrcBook.Close SaveChanges:=False

Next

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

MsgBox "Choose " & countFiles & " files" & vbCrLf & "Finished " & countSheets & " worksheets", Title:="Merge Excel files"
End If

Else
MsgBox "No files selected", Title:="Merge Excel files"
End If
End Sub
 
Web KT
Back
Top Bottom