Question

新用户在这里！我正在创建一个改进的工作跟踪器，其中包含一个＆＃39; Sort＆＃39;触发宏的按钮，用于复制和粘贴“杰出作品”中已完成的工作行。选项卡到＆＃39;已完成＆＃39;选项卡（取决于完成的月份，列U包含基于完成日期的月份编号），使用以下子项：

Sub MoveCompleted()

Dim bottomL As Integer

bottomL = Sheets("Outstanding").Range("A" & Rows.Count).End(xlUp).Row

Dim c As Range
For Each c In Sheets("Outstanding").Range("U5:U" & bottomL)
    If c.Value = "1" Then
    c.EntireRow.Copy Worksheets("Completed - Jan").Range("A" &   Rows.Count).End(xlUp).Offset(1)
    End If
    If c.Value = "2" Then
    c.EntireRow.Copy Worksheets("Completed - Feb").Range("A" & Rows.Count).End(xlUp).Offset(1)
    End If
    If c.Value = "3" Then
    c.EntireRow.Copy Worksheets("Completed - Mar").Range("A" & Rows.Count).End(xlUp).Offset(1)
    End If
    If c.Value = "4" Then
    c.EntireRow.Copy Worksheets("Completed - Apr").Range("A" & Rows.Count).End(xlUp).Offset(1)
    End If
    If c.Value = "5" Then
    c.EntireRow.Copy Worksheets("Completed - May").Range("A" & Rows.Count).End(xlUp).Offset(1)
    End If
    If c.Value = "6" Then
    c.EntireRow.Copy Worksheets("Completed - Jun").Range("A" & Rows.Count).End(xlUp).Offset(1)
    End If
    If c.Value = "7" Then
    c.EntireRow.Copy Worksheets("Completed - Jul").Range("A" & Rows.Count).End(xlUp).Offset(1)
    End If
    If c.Value = "8" Then
    c.EntireRow.Copy Worksheets("Completed - Aug").Range("A" & Rows.Count).End(xlUp).Offset(1)
    End If
    If c.Value = "9" Then
    c.EntireRow.Copy Worksheets("Completed - Sep").Range("A" & Rows.Count).End(xlUp).Offset(1)
    End If
    If c.Value = "10" Then
    c.EntireRow.Copy Worksheets("Completed - Oct").Range("A" & Rows.Count).End(xlUp).Offset(1)
    End If
    If c.Value = "11" Then
    c.EntireRow.Copy Worksheets("Completed - Nov").Range("A" & Rows.Count).End(xlUp).Offset(1)
    End If
    If c.Value = "12" Then
    c.EntireRow.Copy Worksheets("Completed - Dec").Range("A" & Rows.Count).End(xlUp).Offset(1)
    End If
    Next c

End Sub

如果处理大量数据不仅耗费时间，而且有两个用户可以同时触发宏并覆盖其中一个已完成选项卡上的数据。

是否有更有效的方法可以执行此操作，还是有任何可用的代码可以阻止用户触发宏（如果已经在使用中）？感谢

修改

根据Wayne先生的要求，这是我想要移动数据的Outstanding选项卡的截图。

Work Tracker - Outstanding

每个已完成选项卡在布局方面（包括空白标题行）都匹配此选项卡。一旦排序＆＃39;单击按钮，我希望宏在O列中查找包含日期（以dd / mm / yyyy hh：mm：ss格式）的单元格，如果找到，则将单元格A：N中的值移动到相关的＆＃39;已完成标签＆＃39; （它目前移动整行，但由于格式化导致一些文件膨胀问题）。同样的事情需要在N列（＆＃39;简称＆＃39;）中发生，但是只有一个＆＃39; Referred＆＃39;选项卡移动到。然后我有辅助宏删除＆＃39; Outstanding＆＃39;在＆＃39; N＆＃39;中的值或者＆＃39; O＆＃39;。

作为关于运行相同宏的多个用户的原始查询的更新;我已经实现了一个步骤，一旦单击排序按钮，VB就会打开一个已保存的.txt文件并保持打开状态直到宏运行。如果另一个用户尝试运行宏，VB将检查.txt文件是否已打开，如果是，则终止。现在似乎工作得很好，所以感谢大家到目前为止的输入。

Answer 1

试试这个，它是代码的精简版本，L = [['1', '1', '0', '0', '0'],['1', '1', '1', '1', '0'],['0', '0', '1', '1', '0']] D = [''.join(sub_list) for sub_list in L]和Range()正确地固定在我认为你想要的工作表上。另外，我假设你只需要单元格值，你可以通过设置两个等于彼此的范围来更快地做到。这样可以节省一些时间，因为您可以完全跳过剪贴板（Rows.Count）。（感谢{YowE3K简化.Copy）。

If

您可以根据需要进行调整。我不确定您是否希望Sub MoveCompleted() Dim bottomL As Integer With Sheets("Outstanding") bottomL = .Range("A" & .Rows.Count).End(xlUp).Row End With Dim c As Range For Each c In Sheets("Outstanding").Range("U5:U" & bottomL) With Worksheets("Completed - " & Format(DateSerial(2017, c.Value, 1), "mmm")) .Range("A" & .Rows.Count).End(xlUp).Offset(1).EntireRow.Value = Sheets("Outstanding").Rows(c).EntireRow.Value End With Next c End Sub行实际匹配Completed - Jan行，或者您只需要单元格值。另请注意，您基于A列中的单元格数量后面的Sheets("Outstanding")。...然后使用列U获取数据。如果A列只有4个值，您会发生什么？然后你的bottomL可能会抛出错误。

多个用户触发相同的宏

1 个答案: