Question

我有一个Excel文件，其中包含有关240座建筑物的信息，每1、2、3、4 [..]，239、240个有一张表，然后有1张新信息是1（1），1（2），1（3）等。是否可以创建一个选择1（*）的vba，并仅在一个文件中复制1号建筑物的图纸，依此类推，对所有240座建筑物都如此？

编辑。我知道这是不允许的，但是伪代码会像这样

for i=1..240
  Pattern = "([i]\s\(\d\))" ' Sheet name 1 (1), 1 (2) etc
  copy in new file
end

我对vba不够熟悉。

工作表的命名如下：

1, 3, 5, 4, 25, 34, 87, 95, 110, 125, 3 (1), 4 (1), 110 (1), 3 (2), 110 (2), 110 (3)

我需要像这样将它们分组：

1, 1 (1), 1 (2), 1 (3)
2
3 (1)
110, 110 (1), 110 (2)
...

原始命名语法如下：#buildingNum [1-240] space（#update）

Answer 1

这应该做您想要的。工作表的名称将为1,2,3 ...工作表名称将为1（1），1（2），2（1）...如果要为工作簿命名，只需更改键名称

contacts

Answer 2

我不会一口气尝试完成此任务。我看到过这样的任务，其中某些内容未复制到新位置或未复制到错误位置。可能要过几个月才能发现该错误，并且要消除由该错误造成的任何损失可能是昂贵的，甚至是不可能的。

下面是我的解决方案的第一部分。它使用一系列集合，最多可容纳250座建筑物。您认为有240座建筑物，但如果有更多建筑物，请修改Dim WshtGrps(0 To 250) As Collection。它对每个工作表进行分类，并将其名称放在其中一个集合中。如果名称与您的格式不匹配，则将其放在WshtGrps(0)中。对所有工作表进行分类后，集合将输出到桌面文件“ Worksheets.txt”。在我的测试工作簿中，输出为：

Grp|Worksheets -->
  0|Other1|Other2|1.2|251|
  1|1|1 (2)|1 (3)|
  2|2|2 (2)|
  3|3|3 (2)|3 (3)|3 (4)|
  4|4|4 (2)|
  5|5|
 10|10|
 11|11|
 12|12|
 20|20|
 30|30|
100|100|
200|200|
250|250|250 (2)|

您会看到名称不标准或超出范围的工作表显示在顶部。让我们希望您没有WshtGrps（0）的行，但是，如果这样做，您将需要决定如何处理它们。

Option Explicit
Sub SplitWorkbook()

  Dim InxM As Long
  Dim InxW As Long
  Dim Line As String
  Dim NumFile As Long
  Dim NumWsht As Double
  Dim Path As String
  Dim WshtGrps(0 To 250) As Collection

  ' Initialise all the collections
  For InxW = LBound(WshtGrps) To UBound(WshtGrps)
    Set WshtGrps(InxW) = New Collection
  Next

  ' Add the name of all worksheets with integer name N to
  ' WshtGrps(N).  If the name N is not an integer or N is
  ' greater than UBound(WshtGrps) add the name to WshtGrps(0).
  For InxW = 1 To Worksheets.Count
    ' Val() skips any spaces then extracts digits up to the end of the
    ' string or until it reaches a character is does not recognise as
    ' part of a number. It returns zero if no digits are found.
    NumWsht = Val(Worksheets(InxW).Name)
    If NumWsht >= 1 And NumWsht <= UBound(WshtGrps) And CInt(NumWsht) = NumWsht Then
      WshtGrps(NumWsht).Add Worksheets(InxW).Name
    Else
      'NumWsht is out of range or not a integer
      WshtGrps(0).Add Worksheets(InxW).Name
    End If
  Next

  ' Output the worksheet groups to desktop file "Worksheets,txt"
  Path = CreateObject("WScript.Shell").specialfolders("Desktop") & "\Worksheets.txt"
  NumFile = FreeFile
  Open Path For Output As #NumFile
  Print #1, "Grp|Worksheets -->"
  For InxW = LBound(WshtGrps) To UBound(WshtGrps)
    If WshtGrps(InxW).Count > 0 Then
      Line = PadL(InxW, 3)
      For InxM = 1 To WshtGrps(InxW).Count
        Line = Line & "|" & WshtGrps(InxW)(InxM)
      Next
      Line = Line & "|"
      Print #1, Line
    End If
  Next
  Close #1

  ' ###### Delete when you are happy with the contents of Worksheets.txt
  Exit Sub

  Const WbkNameRoot As String = "Building "

  Dim InxW2 As Long
  Dim WbkNew As Workbook
  Dim WbkSrc As Workbook

  ' This assumes the worksheets to be copied are in the workbook
  ' containing this macro.  Amend if necessary.
  Set WbkSrc = ThisWorkbook

  ' Amend if you want the new workbooks to be somewhere else
  Path = WbkSrc.Path & "\"

  Application.ScreenUpdating = False

  For InxW = 1 To UBound(WshtGrps)
    If WshtGrps(InxW).Count > 0 Then
      Set WbkNew = Workbooks.Add

      With WbkNew
        ' Ensure all default worksheet have a name that does not
        ' match sheets to be copied in
        For InxW2 = 1 To .Worksheets.Count
          .Worksheets(InxW2).Name = "Other" & InxW2
        Next

        For InxM = 1 To WshtGrps(InxW).Count
          WbkSrc.Worksheets(WshtGrps(InxW)(InxM)).Copy After:=.Worksheets(.Worksheets.Count)
        Next

        For InxW2 = .Worksheets.Count To 1 Step -1
          If Left$(.Worksheets(InxW2).Name, 5) = "Other" Then
            Application.DisplayAlerts = False
            .Worksheets(InxW2).Delete
            Application.DisplayAlerts = True
          End If
        Next

        .SaveAs Filename:=Path & WbkNameRoot & PadL(InxW, 3, "0") & ".xlsx"
        .Close
      End With
    End If
  Next

  Application.ScreenUpdating = True

End Sub
Public Function PadL(ByVal Str As String, ByVal PadLen As Long, _
                     Optional ByVal PadChr As String = " ") As String

  ' Pad Str with leading PadChr to give a total length of PadLen
  ' If the length of Str exceeds PadLen, Str will not be truncated

  '   Sep15 Coded
  ' 20Dec15 Added code so overlength strings are not truncated
  ' 10Jun16 Added PadChr so could pad with characters other than space

  If Len(Str) >= PadLen Then
    ' Do not truncate over length strings
    PadL = Str
  Else
    PadL = Right$(String(PadLen, PadChr) & Str, PadLen)
  End If

End Function

选择特定的工作表并保存在新文件中

2 个答案: