Nâng cấp lên Excel 2019 tốc độ Macro bị chậm tới hơn 10 phút

Xin chào,

Tôi có một macro trong excel đã được tạo trong phiên bản excel cũ, nhưng vì chúng tôi đã chuyển sang excel 2010 nên macro tương tự sẽ mất rất nhiều thời gian để hoàn thành. Nó cũng đóng băng excel của tôi mà không thể thực hiện hoặc xem gì khác cùng lúc macro chạy.

Macro này so sánh 2 trang dữ liệu và đặt dữ liệu đã hoàn thành vào một trang khác kết hợp dữ liệu và khớp với nhau.

Dưới đây xin vui lòng tìm một bản sao của mã.

Có thể cung cấp tệp XLSM (ẩn danh).

Đang tìm kiếm sự giúp đỡ gấp để có thể làm lại... ;-)

Xin lưu ý rằng kiến ​​thức mã hóa macro của tôi gần như bằng không. Những người đã tạo ra mã không còn ở đó nữa ...

Cảm ơn sự giúp đỡ của bạn.

Kr

Sub TạoInvoice_Click()

'Khi có lỗi Tiếp tục tiếp theo

Dim wb As Workbook

Dim wsListeFacture, wsAdmin, wsDocument, wsRef As Worksheet

Dim nextRow, i As Integer

Dim numTài liệu dạng đôi

Đặt wb = ThisWorkbook

Đặt wsListeFacture = ThisWorkbook.Worksheets(LISTE_FACTURE_SHEET)

Đặt wsAdmin = ThisWorkbook.Worksheets(ADMIN_SHEET)

Đặt wsDocument = ThisWorkbook.Worksheets(FACTURE_SHEET)

Đặt wsRef = ThisWorkbook.Worksheets(REF_SHEET)

Ứng dụng.Tính toán

numDocument = wsAdmin.Range("DOC_NUM").Value

Debug.Print ("kiểm tra numdoc " + CStr(wsAdmin.Range("DOC_NUM").Value))

Gỡ lỗi.Print "numdoc =" + CStr(numDocument)

Dim typeTài liệu dưới dạng chuỗi

typeDocument = wsAdmin.Range("Type_Doc")

hàng tiếp theo = 2

Nếu ((wsAdmin.Range("Type_Doc").Value = "FACT") Hoặc (wsAdmin.Range("Type_Doc").Value = "CN")) thì

' vòng lặp để tìm hàng có sẵn tiếp theo

' 50000: tăng thêm ce nombre si bcp defactures!

tôi = 0

Với i = 2 đến 1000

Gỡ lỗi.In "i=" + CStr(i)

Debug.Print "read1 " + CStr(wsListeFacture.Cells(i, 3).Value)

Debug.Print "read2 " + CStr(wsAdmin.Range("DOC_NUM").Value)

Nếu (wsListeFacture.Cells(i, 3) <> "") Thì

Nếu (wsListeFacture.Cells(i, 1) = typeDocument) Thì

Nếu (wsListeFacture.Cells(i, 3) = wsAdmin.Range("DOC_NUM")) thì

MsgBox ("Ce document #" + CStr(wsAdmin.Range("DOC_NUM")) + " est déjà enregistré ligne " + CStr(i) + " - l'effacer de la liste si nécessaire et recommencer")

wsListeFacture.Activate

wsListeFacture.Cells(i, 1).Select

Thoát phụ

Kết thúc nếu

Kết thúc nếu

hàng tiếp theo = tôi

' quét tất cả phạm vi đề phòng trường hợp có khoảng trống/dòng trống

Kết thúc nếu

Tiếp theo tôi

Kết thúc nếu

Nếu (wsDocument.Range("DOC_HT").Value = 0) Thì

MsgBox ("Erreur, pas de montant HT")

wsDocument.Kích hoạt

wsDocument.Range("DOC_HT").Chọn

Thoát phụ

Kết thúc nếu

' sao chép hóa đơn sang sổ làm việc mới

Dim wbNew As Workbook

Đặt wbNew = Workbooks.Add

wsDocument.Copy Trước:=wbNew.Sheets(1)

wbNew.Sheets(1).Range("A1:AA2000") = wbNew.Sheets(1).Range("A1:AA2000").Value

wbNew.Sheets(1).Range("I1:AA2000").Xóa

wbNew.Kích hoạt

Ứng dụng.Tính toán

' http://www.contextures.com/excelvbapdf.html

'Dim myFile dưới dạng biến thể

' Tiết mục mờ như chuỗi

'repertoire = wsAdmin.Range("REPERTOIRE").Value

Tiền tố mờ dưới dạng chuỗi

Nếu (typeDocument = "FACT") thì

tiền tố = "THỰC TẾ_"

ElseIf (typeDocument = "CN") Sau đó

tiền tố = "NOTE_CREDIT_"

ElseIf (typeDocument = "OFFER") Sau đó

tiền tố = "OFFER_"

ElseIf (typeDocument = "NE") Sau đó

tiền tố = "NE_"

ElseIf (typeDocument = "FT") Sau đó

tiền tố = "FT_"

ElseIf (typeDocument = "AR") thì

tiền tố = "AR_"

KhácNếu (typeDocument = "PRO_F") thì

tiền tố = "PROFORMA_"

ElseIf (typeDocument = "Comd") thì

tiền tố = "CONF_CMD_"

Khác

MsgBox ("Loại tài liệu (FACT, CN...) cần lưu ý trong mã VBA...")

Thoát phụ

Kết thúc nếu

'MacGetSaveAsFilenameExcel MyInitialFilename:=prefix & CStr(numDocument) & ".XLSX", FileExtension:="xlsx"

WindowsGetSaveAsFilenameExcel MyInitialFilename:=prefix & CStr(numDocument) & ".XLSX", FileExtension:="xlsx"

wbNew.Kích hoạt

wbNew.ExportAsFixedFormat _

Loại:=xlTypePDF, _

Chất lượng:=xlTiêu chuẩn chất lượng, _

Bao gồmDocProperties:=Đúng, _

Bỏ quaPrintAreas:=Sai, _

OpenAfterPublish:=Sai

'tin nhắn xác nhận với thông tin tập tin

MsgBox "Tệp PDF đã được tạo"

wbNew.Đóng LưuThay đổi:=False

wb.Kích hoạt

Nếu ((wsAdmin.Range("Type_Doc").Value = "FACT") Hoặc (wsAdmin.Range("Type_Doc").Value = "CN")) thì

hàng tiếp theo = hàng tiếp theo + 1

Debug.Print "chèn hóa đơn vào hàng" + CStr(nextRow)

wsListeFacture.Cells(nextRow, 1) = typeDocument

wsListeFacture.Cells(nextRow, 2) = "Q" & DatePart("q", wsDocument.Range("DATE_DOC"))

wsListeFacture.Cells(nextRow, 3) = numDocument

wsListeFacture.Cells(nextRow, 4) = wsAdmin.Range("SOCIETE") + " " + wsAdmin.Range("NOM_CONTACT")

wsListeFacture.Cells(nextRow, 5) = Format(wsDocument.Range("DATE_DOC"), "dd/mm/yyyy")

wsListeFacture.Cells(nextRow, 7) = wsDocument.Range("DOC_A_PAYER")

wsListeFacture.Cells(nextRow, 8) = wsDocument.Range("DOC_HT")

wsListeFacture.Cells(nextRow, 9) = wsDocument.Range("VOSREF")

wsListeFacture.Cells(nextRow, 10) = wsAdmin.Range("ĐẠI DIỆN")

Kết thúc nếu

' tạo số hóa đơn tiếp theo

numTài liệu = numTài liệu + 1

Nếu (wsAdmin.Range("Type_Doc").Value = "FACT") thì

wsAdmin.Range("NEXT_NUM_FACTURE").Value = numDocument

ElseIf (wsAdmin.Range("Type_Doc").Value = "CN") Sau đó

wsAdmin.Range("NEXT_NUM_NC").Value = numDocument

ElseIf (wsAdmin.Range("Type_Doc").Value = "PRO_F") Sau đó

wsAdmin.Range("NEXT_NUM_PF").Value = numDocument

Khác

wsAdmin.Range("NEXT_NUM_AUTRE").Value = numDocument

Kết thúc nếu

Nếu ((wsAdmin.Range("Type_Doc").Value = "FACT") Hoặc (wsAdmin.Range("Type_Doc").Value = "CN")) thì

MsgBox ("Xong, loại tài liệu " + typeDocument + " généré avec # " + CStr(numDocument - 1))

wsListeFacture.Activate

wsListeFacture.Cells(nextRow, 1).Select

Kết thúc nếu

Kết thúc phụ

Hàm WindowsGetSaveAsFilenameExcel(MyInitialFilename As String, FileExtension As String)

Làm mờ myFile dưới dạng biến thể

' lưu dưới dạng XLS

Debug.Print "myinitialFileName = " + CStr(MyInitialFilename) + " phần mở rộng tệp tệp của tôi =" + FileExtension

'myFile = Application.GetSaveAsFilename(initialFileName:=MyInitialFilename, _

FileFilter:=Phần mở rộng tệp, _

Tiêu đề:="Chọn thư mục và tên tệp để lưu")

ActiveWorkbook.SaveAs MyInitialFilename, FileFormat:=51

'myFile = Application.GetSaveAsFilename(initialFileName:=MyInitialFilename)

' FName = Application.GetSaveAsFilename(initialFileName:=MyInitialFilename)

'Nếu myFile <> "Sai" thì

' ActiveWorkbook.SaveAs _

' Tên tệp:=myFile

'tin nhắn xác nhận với thông tin tập tin

MsgBox "Tệp XLS đã được tạo: " _

& vbCrLf _

& Tên tệp ban đầu của tôi

'Kết thúc nếu

Chức năng kết thúc

Hàm MacGetSaveAsFilenameExcel(MyInitialFilename Dưới dạng chuỗi, FileExtension dưới dạng chuỗi)

'Ron de Bruin, 03-04-2015

'Chức năng tùy chỉnh dành cho máy Mac để lưu sổ làm việc đang hoạt động theo định dạng bạn muốn.

'Nếu FileExtension = "" bạn có thể lưu ở các định dạng sau: xls, xlsx, xlsm, xlsb

'Bạn cũng có thể đặt FileExtension thành tiện ích mở rộng bạn muốn như "xlsx" chẳng hạn

Dim FName làm biến thể

Dim FileFormatValue Càng dài

Kiểm tra mờ nếu mở dưới dạng sổ làm việc

Dim FileExtGetSaveAsFilename dưới dạng chuỗi

Một lần nữa: FName = Sai

'Gọi VBA GetSaveAsFilename

'Lưu ý: Tên tệp ban đầu là tham số duy nhất hoạt động trên máy Mac

MsgBox ("Sẽ lưu " + MyInitialFilename)

FName = Application.GetSaveAsFilename(initialFileName:=MyInitialFilename)

Nếu FName <> Sai thì

'Nhận phần mở rộng của tập tin

FileExtGetSaveAsFilename = LCase(Right(FName, Len(FName) - InStrRev(FName, ".", , 1)))

Nếu FileExtension <> "" Thì

Nếu FileExtension <> FileExtGetSaveAsFilename thì

MsgBox "Xin lỗi, bạn phải lưu tệp ở định dạng này: " & FileExtension

Đi tới lần nữa

Kết thúc nếu

Nếu ActiveWorkbook.HasVBProject = True Và LCase(FileExtension) = "xlsx" thì

MsgBox "Sổ làm việc của bạn có mã VBA, vui lòng không lưu ở định dạng xlsx"

Thoát chức năng

Kết thúc nếu

Khác

Nếu ActiveWorkbook.HasVBProject = True Và LCase(FileExtGetSaveAsFilename) = "xlsx" thì

MsgBox "Sổ làm việc của bạn có mã VBA, vui lòng không lưu ở định dạng xlsx"

Đi tới lần nữa

Kết thúc nếu

Kết thúc nếu

'Tìm đúng FileFormat phù hợp với lựa chọn trong danh sách "Save as type"

'và đặt FileFormatValue, Extension và FileFormatValue phải khớp nhau.

'Lưu ý: Bạn có thể thêm hoặc xóa các mục vào/từ danh sách bên dưới nếu muốn.

Chọn Case FileExtGetSaveAsFilename

Trường hợp "xls": FileFormatValue = 57

Trường hợp "xlsx": FileFormatValue = 52

Trường hợp "xlsm": FileFormatValue = 53

Trường hợp "xlsb": FileFormatValue = 51

Trường hợp khác: FileFormatValue = 0

Kết thúc chọn

Nếu FileFormatValue = 0 thì

MsgBox "Xin lỗi, FileFormat không được phép"

Đi tới lần nữa

Khác

'Lỗi kiểm tra xem có file nào đang mở với tên đó không

Đặt TestIfOpen = Không có gì

Khi xảy ra lỗi Tiếp tục tiếp theo

Đặt TestIfOpen = Workbooks(LCase(Right(FName, Len(FName) - InStrRev(FName, _

Application.PathSeparator, , 1))))

Khi có lỗi Chuyển tới 0

Nếu không TestIfOpen thì chẳng là gì cả

MsgBox "Bạn không được phép ghi đè lên tập tin đang mở có cùng tên," & _

"sử dụng tên khác hoặc đóng tệp có cùng tên trước."

Đi tới lần nữa

Kết thúc nếu

Kết thúc nếu

'Bây giờ chúng ta đã có thông tin để Lưu file

Application.DisplayAlerts = Sai

Khi xảy ra lỗi Tiếp tục tiếp theo

ActiveWorkbook.SaveAs FName, FileFormat:=FileFormatValue

Khi có lỗi Chuyển tới 0

Application.DisplayAlerts = Đúng

Kết thúc nếu

Chức năng kết thúc

>

Trả lời:

Nếu bạn gửi cho tôi một bản sao của (các) sổ làm việc có tham chiếu chuỗi này trong email kèm theo, tôi sẽ điều tra vấn đề.

Trả lời:

Nếu bạn gửi cho tôi bản sao của (các) sổ làm việc có tham chiếu chuỗi này trong email kèm theo, tôi sẽ điều tra vấn đề.

Tôi Doug, tôi vừa gửi email cho bạn (từ Hydrokube.be)

Cảm ơn bạn đã quan tâm đến vấn đề của tôi,

Marc