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

问题描述 投票：0回答：2

在我的工作表中，包含超过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
excel cell copying info
2个回答
0
投票

你宣布了​​RowNo的价值吗？

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

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

0
投票

我几乎解决了我的所有问题。宏（下面的代码）工作正常，虽然花了相当长的时间，由于我猜测的处理量但是，完全执行宏的唯一方法是直接从VBA执行。如果我使用我指定的快捷键Ctrl + Shift + T，打开文件后maccro停止，没有数据复制，没有保存文件......任何想法为什么？

Sub CREERTS（）''CREERTS Macro''键盘快捷键：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

结束子

最新问题
© www.soinside.com 2019 - 2024. All rights reserved.