Question

在解释这段代码之前有点了解，首先用户将打开一个空的microsoft excel，然后用户将在宏上打开多个工作簿到当前活动的excel中，例如，如果用户选择要打开“book1”和“book2”，当前活动的excel将打开它们并将它们拆分成一个以当前命名的工作簿命名的新工作表，例如工作表“book1”和工作表“book2”。

所以基本上这个程序使用户能够搜索一个字符串（在所有工作表中），然后在找到字符串的位置后，将整个行+标题复制到一个以搜索字符串命名的新工作表。

例如，如果我搜索苹果，它将复制整个行包含单词“apple”并粘贴到名为“apple”的新工作表中，行和标题将被复制到那里，我需要什么现在要做的是创建一个新的工作簿，并创建一个以搜索字符串和之前命名的工作簿命名的新工作表。

就像我说的那样，我打开了工作簿“book1”和“book2”，如果搜索到的单词来自工作表“book1”，宏将把搜索到的字符串复制到一个新的工作簿中，一个名为“book1”的新工作表“有了这些信息。

我知道我已经非常罗嗦地解释了这一点，如果您需要任何澄清，请告诉我。

    Private Sub CommandButton5_Click()
   Dim i As Long, nRowsAddePerSheet As Long, nRows As Long, _
    nRowsMax As Long, nSheets As Long
  Dim strSearch, strSearch2
  Dim rg As Range, rgF As Range
  Dim wks
  Dim x

  strSearch = Application.InputBox("Please enter the search string")
  strSearch2 = Replace(strSearch, "*", "")
  If Len(strSearch2) <= 0 Then
    MsgBox "ABandon: Search string must not be empty."
    Exit Sub
  End If

  Application.ScreenUpdating = False

  nSheets = Sheets.Count
  nRowsMax = ActiveSheet.Rows.Count

  For x = 1 To nSheets

    On Error Resume Next
    Set wks = Worksheets(strSearch2)
    If (Err) Then
      Set wks = Worksheets.Add(After:=Sheets(Sheets.Count))
      wks.Name = strSearch2
      Err.Clear
    End If
    On Error GoTo 0

    Sheets(x).Activate
    Set rg = ActiveSheet.Cells(1).CurrentRegion

    nRows = rg.Rows.Count
    nRowsAddePerSheet = 0
    For i = 1 To nRows
      Set rgF = rg.Rows(i).Find(strSearch, , xlValues, xlWhole)

      If Not rgF Is Nothing Then

        If (nRowsAddePerSheet <= 0) Then
          If (i <> 1) Then
            rg.Rows(1).Copy wks.Range("A" & nRowsMax).End(xlUp).Offset(1, 0)
          End If
        End If

        rg.Rows(i).Copy wks.Range("A" & nRowsMax).End(xlUp).Offset(1, 0)
        nRowsAddePerSheet = nRowsAddePerSheet + 1
      End If
    Next
  Next

  Set rgF = Nothing
  Set rg = Nothing
  Set wks = Nothing

  Application.ScreenUpdating = True

End Sub

Answer 1

这是你在尝试的吗？

评论后续跟进：想法是保存文件，然后检查该文件是否存在。如果它存在，则找到最后一行，然后在那里输入数据。选项明确

Dim HeaderExists As Boolean

Sub Sample()
    Dim wb As Workbook, wbNew As Workbook
    Dim ws As Worksheet, wsNew As Worksheet
    Dim strSearch As String
    Dim aCell As Range, bCell As Range
    Dim LRow As Long, nCol As Long

    strSearch = Application.InputBox("Please enter the search string")

    If strSearch = "" Then
        MsgBox "ABandon: Search string must not be empty."
        Exit Sub
    End If

    '~~> Check if a workbook with the name already exists
    For Each wb In Application.Workbooks
        If InStr(1, wb.Name, strSearch & ".xl", vbTextCompare) Then
            Set wbNew = wb
            On Error Resume Next
            Set wsNew = wbNew.Sheets(strSearch)
            On Error GoTo 0
            Exit For
        End If
    Next

    If Not wsNew Is Nothing Then
        If Application.WorksheetFunction.CountA(wsNew.Cells) <> 0 Then
            HeaderExists = True
            LRow = wsNew.Cells.Find(What:="*", _
                    After:=wsNew.Range("A1"), _
                    Lookat:=xlPart, _
                    LookIn:=xlFormulas, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False).Row + 1

        End If
    End If

    '~~> Add the new workbook
    If wbNew Is Nothing Then
        Set wbNew = Workbooks.Add
        wbNew.SaveAs "C:\" & strSearch & ".xls", FileFormat:=56
        Set wsNew = wbNew.Sheets(1)
        wsNew.Name = strSearch
    End If

    If LRow = 0 Then LRow = 1

    '~~> Loop through all workbooks and worksheets to find the word
    For Each wb In Application.Workbooks
        If wb.Name <> wbNew.Name Then
            For Each ws In wb.Worksheets
                Set aCell = ws.Cells.Find(What:=strSearch, LookIn:=xlValues, _
                    Lookat:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                    MatchCase:=False, SearchFormat:=False)

                If Not aCell Is Nothing Then
                    Set bCell = aCell

                    nCol = aCell.Row

                    If HeaderExists = False Then
                        ws.Rows(1).Copy wsNew.Rows(1)
                        LRow = LRow + 1
                    End If


                    ws.Rows(aCell.Row).Copy wbNew.Sheets(1).Rows(LRow)

                    LRow = LRow + 1

                    Do
                        Set aCell = ws.Cells.FindNext(After:=aCell)

                        If Not aCell Is Nothing Then
                            If aCell.Address = bCell.Address Then Exit Do

                            If nCol <> aCell.Row Then
                                ws.Rows(aCell.Row).Copy wsNew.Rows(LRow)
                                LRow = LRow + 1
                            End If
                        Else
                            Exit Do
                        End If
                    Loop
                End If
            Next
        End If
    Next
End Sub

搜索字符串后打开工作簿

1 个答案: