Question

我需要一个脚本来根据电子表格的名称自动将来自同一工作簿的多个Excel电子表格合并到一个电子表格中。但是，电子表格的名称使用不同的名称。例如：0000a，0000b，0000c ....我如何比较名称的前四个数字，如果相似，将它们组合成一个名为0000的电子表格？提前感谢您的帮助

Answer 1

使用Worksheet.Name获取名称，即：

Dim ws as Worksheet
For Each ws in Worksheets
 MsgBox Left(ws.Name, 4)
Next ws

使用Left，您可以提取前4个字母。如果您将它们存储在array中，则可以使用Application.Match - 函数来匹配array中的值。使用索引，您可以参考Worksheets(index)。

编辑：

Sub ad()
Dim ws As Worksheet
Dim lc As Range, lc1 As Range
Dim arr() As String, index As Long, Count As Long

Count = Worksheets.Count
ReDim arr(1 To Count) 'Array to store worksheetsnames

For i = 1 To Count
 arr(i) = Left(Worksheets(i).Name, 4) 'cut 4 letters and store in array
Next

On Error Resume Next

For i = Count To 2 Step -1
 sval = arr(i) 'search value
 ReDim Preserve arr(1 To i - 1) 'downsize array
 index = Application.Match(sval, arr(), 0) 'find matching name in array

    With Worksheets(index) 'lrow on ws to paste
        Set lc = .Cells.Find(what:=Chr(42), after:=.Cells(1), searchdirection:=xlPrevious, _
                         lookat:=xlPart, searchorder:=xlByRows, LookIn:=xlFormulas)
    End With
    With Worksheets(i) 'lrow on ws to copy
        Set lc1 = .Cells.Find(what:=Chr(42), after:=.Cells(1), searchdirection:=xlPrevious, _
                         lookat:=xlPart, searchorder:=xlByRows, LookIn:=xlFormulas)
    End With

    Worksheets(i).Range("A1:" & lc1.Address).Copy Worksheets(index).Range("A" & lc.Row + 1) 'copy paste
    Worksheets(index).Name = sval 'rename to first 4 letters
    Application.DisplayAlerts = False
    Worksheets(i).Delete
    Application.DisplayAlerts = True
Next i
End Sub

根据名称在excel中组合电子表格

1 个答案: