Question

在包含超过2k行的工作表中，我需要创建一个宏，该宏将自动打开另一个文件，然后将所选行中第一个工作表中的某些数据复制到新创建/打开的特定单元格中文件

我尝试了以下代码，但是似乎停留在第一次复制操作上（TECHNICAL SHEET-2020v2.xlsm是新创建的文件，而SuiviNouveautés2020.xlsx是我需要制作的实际工作表宏，我需要在其中复制数据

Sub CREERTS()
'
' CREERTS Macro
'
' Touche de raccourci du clavier: Ctrl+Shift+T
'

Dim RowNo As Long

Workbooks.Open Filename:= _
    "Myserveradress/filename.xlsm"
ActiveWindow.Visible = False
Windows("TECHNICAL SHEET-2020v2.xlsm").Visible = True
Sheets("SPECIFICATION").Select
ActiveWindow.SmallScroll Down:=-60
Range("C12:J12").Select
ActiveWindow.ScrollColumn = 30
ActiveWindow.ScrollColumn = 29
ActiveWindow.ScrollColumn = 28
ActiveWindow.ScrollColumn = 22
ActiveWindow.ScrollColumn = 12
Windows("Suivi Nouveautés 2020.xlsx").Activate
Range("J" & RowNo).Copy
Windows("TECHNICAL SHEET-2020v2.xlsm").Activate
Range("B6:B7").Paste
Windows("Suivi Nouveautés 2020.xlsx").Activate
Range("Q" & RowNo).Copy
Windows("TECHNICAL SHEET-2020v2.xlsm").Activate
Range("F8:H11").Paste
Windows("Suivi Nouveautés 2020.xlsx").Activate
Range("O" & RowNo).Copy
Windows("TECHNICAL SHEET-2020v2.xlsm").Activate
Range("B8:C11").Paste
Windows("Suivi Nouveautés 2020.xlsx").Activate
Range("F" & RowNo).Copy
Windows("TECHNICAL SHEET-2020v2.xlsm").Activate
Range("A13").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Windows("Suivi Nouveautés 2020.xlsx").Activate
Range("S" & RowNo).Copy
Windows("TECHNICAL SHEET-2020v2.xlsm").Activate
Range("E36").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Windows("Suivi Nouveautés 2020.xlsx").Activate
Range("T" & RowNo).Copy
Windows("TECHNICAL SHEET-2020v2.xlsm").Activate
Range("E37").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Windows("Suivi Nouveautés 2020.xlsx").Activate
Range("U" & RowNo).Copy
Windows("TECHNICAL SHEET-2020v2.xlsm").Activate
Range("E38").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Windows("Suivi Nouveautés 2020.xlsx").Activate
Range("AF" & RowNo).Copy
Windows("TECHNICAL SHEET-2020v2.xlsm").Activate
Range("E40").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

End Sub

Answer 1

您是否声明了RowNo的值？

您可以在代码的开头使用Application.ScreenUpdating = False和Application.Calculation = xlCalculationManual，在代码的结尾使用Application.ScreenUpdating = True和Application.Calculation = xlCalculationAutomatic优化代码。

您还可以删除所有这些ActiveWindow.ScrollCollumn语句。他们没用。

Answer 2

我几乎解决了所有问题。宏（下面的代码）正在正常工作，尽管由于我估计处理量很大，但是要花一些时间但是，完全执行宏的唯一方法是直接从VBA执行。如果我使用指定的快捷键Ctrl + Shift + T，则打开文件后宏停止，没有数据被复制，没有保存文件... 知道为什么吗？

子CREERTS（） ' CREERTS宏 ' '键盘触摸屏：Ctrl + Shift + T '

Dim RowNo As Long
RowNo = Selection.Row '<- Here you get the row number you have select

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Workbooks.Open FileName:= _
    "\\MYSERVERADRESS\filename.xlsm"
ActiveWindow.Visible = False
Windows("TECHNICAL SHEET-2020v2.xlsm").Visible = True
Sheets("SPECIFICATION").Select
Range("B6:B7").Select
Windows("Suivi Nouveautés 2020.xlsm").Activate
Range("J" & RowNo).Copy
Windows("TECHNICAL SHEET-2020v2.xlsm").Activate
Range("B6:B7").PasteSpecial xlPasteAll
Windows("Suivi Nouveautés 2020.xlsm").Activate
Range("K" & RowNo).Copy
Windows("TECHNICAL SHEET-2020v2.xlsm").Activate
Range("E6").PasteSpecial xlPasteAll
Windows("Suivi Nouveautés 2020.xlsm").Activate
Range("R" & RowNo).Copy
Windows("TECHNICAL SHEET-2020v2.xlsm").Activate
Range("F8:H11").PasteSpecial xlPasteAll
Windows("Suivi Nouveautés 2020.xlsm").Activate
Range("P" & RowNo).Copy
Windows("TECHNICAL SHEET-2020v2.xlsm").Activate
Range("B8:C11").PasteSpecial xlPasteAll
Windows("Suivi Nouveautés 2020.xlsm").Activate
Range("Y" & RowNo).Copy
Windows("TECHNICAL SHEET-2020v2.xlsm").Activate
Range("J5").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Windows("Suivi Nouveautés 2020.xlsm").Activate
Range("Z" & RowNo).Copy
Windows("TECHNICAL SHEET-2020v2.xlsm").Activate
Range("J6").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Windows("Suivi Nouveautés 2020.xlsm").Activate
Range("AB" & RowNo).Copy
Windows("TECHNICAL SHEET-2020v2.xlsm").Activate
Range("J9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Windows("Suivi Nouveautés 2020.xlsm").Activate
Range("AE" & RowNo).Copy
Windows("TECHNICAL SHEET-2020v2.xlsm").Activate
Range("J10").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Windows("Suivi Nouveautés 2020.xlsm").Activate
Range("F" & RowNo).Copy
Windows("TECHNICAL SHEET-2020v2.xlsm").Activate
Range("A13").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Windows("Suivi Nouveautés 2020.xlsm").Activate
Range("G" & RowNo).Copy
Windows("TECHNICAL SHEET-2020v2.xlsm").Activate
Range("A16").PasteSpecial xlPasteAll
Windows("Suivi Nouveautés 2020.xlsm").Activate
Range("T" & RowNo).Copy
Windows("TECHNICAL SHEET-2020v2.xlsm").Activate
Range("E36").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Windows("Suivi Nouveautés 2020.xlsm").Activate
Range("U" & RowNo).Copy
Windows("TECHNICAL SHEET-2020v2.xlsm").Activate
Range("E37").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Windows("Suivi Nouveautés 2020.xlsm").Activate
Range("V" & RowNo).Copy
Windows("TECHNICAL SHEET-2020v2.xlsm").Activate
Range("E38").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Windows("Suivi Nouveautés 2020.xlsm").Activate
Range("AH" & RowNo).Copy
Windows("TECHNICAL SHEET-2020v2.xlsm").Activate
Range("E40").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Range("J1") = Date

Dim FilePath As String
Dim FileName As String


FilePath = "MyfolderIwanttosavethefileto"
FileName = "TS-DEV" & "-" & Range("A13") & "-" & Range("B6") & "-" & Format(Now(), "YYYY-MM-DD")

'It saves .PDF file at your Descrop with the name of the worksheet
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs FileName:=FilePath & FileName & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
Application.DisplayAlerts = True
ActiveWorkbook.Close

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

结束子

创建一个新的工作簿，使用宏复制一些数据

2 个答案: