从共享文件夹上的另一个excel工作簿复制并粘贴到同一文件夹

3df52oht  于 2023-05-30  发布在  其他
关注(0)|答案(2)|浏览(132)

请与我裸露我下面的问题，我一直在这3个月的工作，我不能得到我的头周围。
我必须解释整个项目，以便您可以理解我希望我的代码做什么：
我已经创建了一个用户表单，这是数据输入，它将由3个用户在同一时间使用，每个用户在PC上有相同的Excel工作簿“输入应用程序”和数据输入一张名为“新回合”每个用户数据条目有一个序列号，例如1 - 1000开始。以及共享文件夹上的另一个工作簿，该共享文件夹用于将由3个用户输入的所有数据复制并粘贴到共享工作簿“DATABASE”上，然后将“数据库”上收集的数据再次复制并粘贴到同一工作簿“入学申请”上但在另一个工作表中，以便在排序时镜像到用户的共享工作簿，从而对数据的序列号进行排序正确的为每个用户，FOT，我有相同的工作簿为3个用户，但每个人只是改变了他们的范围，使他们的数据被复制的范围，使他们不清除其他用户的数据条目，例如：用户1的粘贴范围是A1：N2000，用户2的粘贴范围是A2001：N4000，用户3的粘贴范围是A4001：N6000，然后当再次粘贴到其工作簿中时，它们都被分类，该工作簿是具有用户表单的“数据应用程序”。
“数据库”工作簿，这是共享的，所有收集的数据都在其中，以防止重复条目的用户（这是在一个不同的模块），但现在我的斗争是我试图有更少的时间和更有效地完成，使我不必使用屏幕更新和打开激活保存关闭工作簿的所有时间，这可能会使工作缓慢，可能会崩溃。
我已经读到了一个伟大的线程在这里现在关于父对象，显然保存了大量的时间和错误，为我同样的需要，但我不知道什么，所以以往任何时候都如何反映在我的用户表单工作簿，以及如何调整我的代码。
请帮我调整一下我的代码，希望我解释的正确。

Sub DATA_BASE_ARCHIVE_FullArchive()

Application.ScreenUpdating = False

Windows("ENTRY APPLICATION.xlsm").Activate
Sheets("NEWROUND").Select
Range("A1:N2000").Select

Selection.Copy

Workbooks.Open filename:= _
    "\\2-2023\DATABASE.xlsm"
Windows("DATABASE.xlsm").Activate
Range("A2001").Select
Sheets("FullArchive").Paste
Cells.Select
Range("A2001").Activate
Application.CutCopyMode = False
Selection.Copy

Windows("ENTRY APPLICATION.xlsm").Activate
Sheets("ARCHIVE").Select

Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveWorkbook.Worksheets("ARCHIVE").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("ARCHIVE").Sort.SortFields.ADD Key:=Columns("L:L") _
    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("ARCHIVE").Sort.SortFields.ADD Key:=Columns("A:A") _
    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("ARCHIVE").Sort
    .SetRange Columns("A:P")
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

Windows("DATABASE.xlsm").Activate
ActiveWorkbook.Save
ActiveWindow.Close
Application.CutCopyMode = False
Windows("ENTRY APPLICATION.xlsm").Activate
Sheets("FORM").Select
End Sub

请原谅我复杂的解释，但是我正在做的事情已经够复杂的了！所以请帮帮忙谢谢。
根据我从@stringeater收到的第一个答案编辑的代码。请检查一下然后帮我调整一下。我只是得到一个错误，现在在setwbkDATABAS = Nothing

Sub DATA_BASE_ARCHIVE_FullArchive()

Dim rngNEWROUND As Excel.Range
Dim arrNEWROUND As Variant
Dim wbkDATABASE As Excel.Workbook
Dim rngDataTarget As Excel.Range
Dim rngDataSource As Excel.Range
Dim varData As Variant
Dim rngArchive As Excel.Range

Application.ScreenUpdating = False

Set rngNEWROUND = ThisWorkbook.Sheets("NEWROUND").Range("A1:N2000")

arrNEWROUND = ThisWorkbook.Sheets("NEWROUND").Range("A1:N2000")

Set wbkDATABASE = Workbooks.Open(filename:="E:\DELEGATION APPLICATION SAMPLE\2-2023\DATABASE.xlsm")

Set rngDataTarget = wbkDATABASE.Sheets("FullArchive").Range("A2001")

Set rngDataTarget = rngDataTarget.Resize(UBound(arrNEWROUND, 1), UBound(arrNEWROUND, 2))

rngDataTarget.Value = arrNEWROUND 

Set rngDataSource = rngDataTarget.Worksheet.Range("A2001")

varData = rngDataSource.Value 
wbkDATABASE.Save
wbkDATABASE.Close

setwbkDATABASE = Nothing '(and Im getting error here)

Set rngArchive = ThisWorkbook.Sheets("ARCHIVE").Range("A1") 'reference range

rngArchive.Value = varData   
   
   
ThisWorkbook.Worksheets("ARCHIVE").Sort.SortFields.Clear
ThisWorkbook.Worksheets("ARCHIVE").Sort.SortFields.ADD Key:=Columns("L:L"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ThisWorkbook.Worksheets("ARCHIVE").Sort.SortFields.ADD Key:=Columns("A:A"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

With ThisWorkbook.Worksheets("ARCHIVE").Sort
      .SetRange Columns("A:P")
      .Header = xlGuess
      .MatchCase = False
      .Orientation = xlTopToBottom
      .SortMethod = xlPinYin
      .Apply
End With

Application.ScreenUpdating = True

Sheets("FORM").Select

End Sub
excel

2条答案

按热度按时间
zte4gxcn

zte4gxcn1#

我已经注解掉了你的代码行，并把我的代码行放在下面，这样你就可以看到如何“翻译”你的代码。您可以进一步缩短代码，但代码可能不会变得更容易理解。

Sub DATA_BASE_ARCHIVE_FullArchive()
  
        'declarations
  Dim rngNewRound As Excel.Range    'range object in ThisWorkbook
  Dim arrNewRound As Variant        '2-dim array with content of range
  Dim wbkDatabase As Excel.Workbook 'DATABASE object
  Dim rngDataTarget As Excel.Range  'target range in database
  Dim rngDataSource As Excel.Range  'source range in database
  Dim varData As Variant            'cell content from database
  Dim rngArchive As Excel.Range     'target range on sheet ARCHIVE

  Application.ScreenUpdating = False 'don't forget ... = True at the end
    
  'Windows("ENTRY APPLICATION.xlsm").Activate
  'Sheets("NEWROUND").Select
  'Range("A1:N2000").Select
        'supposing that this VBA code is contained in ENTRY APPLICATIN.xlsm
  Set rngNewRound = ThisWorkbook.Sheets("NEWROUND").Range("A1:N2000") 'reference range
  'Selection.Copy
  arrNewRound = rngNewRound.Value 'save the content of the range in an array
    
  'Workbooks.Open Filename:="\\2-2023\DATABASE-2-2023.xlsm"
  Set wbkDatabase = Workbooks.Open(Filename:="\\2-2023\DATABASE-2-2023.xlsm")
        'is DATABASE.xlsm = DATABASE-2-2023.xlsm? Please clarify!
  'Windows("DATABASE.xlsm").Activate
  'Range("A2001").Select
  Set rngDataTarget = wbkDatabase.Sheets("FullArchive").Range("A2001") 'set top-left corner
        'resize the range so that it matches the size of the array
  Set rngDataTarget = rngDataTarget.Resize(UBound(arrNewRound, 1), UBound(arrNewRound, 2))
  'Sheets("FullArchive").Paste
  rngDataTarget.Value = arrNewRound 'insert array to range
  
  'Cells.Select
  'Range("A2001").Activate
  Set rngDataSource = rngDataTarget.Worksheet.Range("A2001") 'new range in same worksheet
  'Application.CutCopyMode = False
  'Selection.Copy
  varData = rngDataSource.Value     'save range value to single variable
  wbkDatabase.Save                  'save the database
  wbkDatabase.Close                 'close the database
  Set wbkDatabase = Nothing         'release memory
  
  'Windows("ENTRY APPLICATION.xlsm").Activate
  'Sheets("ARCHIVE").Select
  'Range("A1").Select
  Set rngArchive = ThisWorkbook.Sheets("ARCHIVE").Range("A1") 'reference range
  'ActiveSheet.Paste
  'Application.CutCopyMode = False
  rngArchive.Value = varData        'insert single variable to cell A1
  
  'The sorting is probably ok. Please use ThisWorkbook instead of ActiveWorkbook
  ActiveWorkbook.Worksheets("ARCHIVE").Sort.SortFields.Clear
  ActiveWorkbook.Worksheets("ARCHIVE").Sort.SortFields.Add Key:=Columns("L:L"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
  ActiveWorkbook.Worksheets("ARCHIVE").Sort.SortFields.Add Key:=Columns("A:A"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
  With ActiveWorkbook.Worksheets("ARCHIVE").Sort
      .SetRange Columns("A:P")
      .Header = xlGuess
      .MatchCase = False
      .Orientation = xlTopToBottom
      .SortMethod = xlPinYin
      .Apply
    End With
  End With
  
  Windows("DATABASE.xlsm").Activate
  ActiveWorkbook.Save
  ActiveWindow.Close
  Application.CutCopyMode = False
  Windows("ENTRY APPLICATION.xlsm").Activate
  
  Application.ScreenUpdating = True 'otherwise you may not see the updated result
  
  Sheets("FORM").Select

End Sub
赞(0）分享  回复(0）举报  2023-05-30
waxmsbnn

waxmsbnn2#

因为我没有你的样本和所有的密码，我只能想象。请尝试使用Range object而不是Selection，除非你想看到它在运行时运行，否则，没有必要刷新屏幕。在您的代码中：
应用程序。屏幕更新= False

ScreenUpdating = False你还说

这样我就不必一直使用屏幕更新和打开、保存、关闭工作簿。这样我就不必一直使用screenupdate和打开激活保存关闭工作簿，这会使工作变慢甚至可能崩溃。
此外：
我希望一种更非人类的方法更快、更有效
因此，最好使用Range代替Selection来实现。这与Word和PowerPointVBA中的原理相同。* 除非你需要刷新屏幕，或者某些东西需要有焦点来进行操作，否则你实际上不应该使用Selection。* 我认为@Stringeater楼上的回答已经做到了这一点，所以他注解掉了你的Selection语句，并使用下面的Range对象来执行它。
如果您仍然不清楚或有疑问，请再次告诉我们。
20230527 12：59 （CST）
如果您只想将结果保存为Excel文件（带或不带代码），这很容易做到。最简单的方法是将其保存在本地，然后用CopyFile method覆盖目标文件。如果本地保存是不可能的，只允许另存为，那么ExcelVBA中的SaveAs方法将不得不使用。多任务阅读冲突的研究更为复杂。我相信@Stringeater会想出一个很好的解决方案，就像他以前做的那样。谢谢你

赞(0）分享  回复(0）举报  2023-05-30
我来回答

相关问题

    查看更多

    热门标签

    更多
    JavaquerypythonNode开发语言requestUtil数据库Table后端算法LoggerMessageElementParser

    最新问答

    更多
    • 蜀ICP备2022004421号-2 NULL123 https://www.null123.com © All rights reserved
    • 本站内容来源互联网,如果侵犯您的权益请联系我们删除, 联系方式：448109455@qq.com