Question

我对VBA完全不熟悉，我正在尝试编写一个excel模块脚本，以便在工作簿的每个工作表上提取特定部分并对其进行格式化，并在新工作簿上一起输出为1张。

到目前为止，我有这个;

Public Sub extractCol()

    ' Find FF&E Section, Add 3 rows and Identify relevant columns.

    Dim rFind As Range

    With Range("A:A")
        Set rFind = .Find(What:="FF&E", LookAt:=xlWhole, MatchCase:=False, 
        SearchFormat:=False)
        If Not rFind Is Nothing Then

            NumRange = rFind.Row + 3 ' Find FF&E line and add three
            CRange = "C" & NumRange & ":" & "C" & NumRange + 100 ' Define First 100 
            Lines in Column C
            ERange = "E" & NumRange & ":" & "E" & NumRange + 100 ' Define First 100 
            Lines in Column E
            KRange = "K" & NumRange & ":" & "K" & NumRange + 100 ' Define First 100 
            Lines in Column K
            MRange = "M" & NumRange & ":" & "M" & NumRange + 100 ' Define First 100 
            Lines in Column M


            Set range1 = Union(Range(CRange), Range(ERange), Range(KRange), 
            Range(MRange)) ' Combine individual column ranges in to one selection
            range1.Copy ' Copy new combined range

            Set NewBook = Workbooks.Add ' Open new Workbook
            ActiveCell.PasteSpecial Paste:=xlPasteValues ' Paste to new Workbook

        End If

    End With

End Sub

这很棒，因为它提取了我不正确的位但它只是当前的工作表。如何循环使用以完成所有工作表？

其次我想将所有结果粘贴到同一张纸上？

最后我有以下脚本提取工作表名称并对其进行格式化。理想情况下，我想在上面的输出中添加一列，根据它来自哪张表格显示这些数据。

Function FindRoom()

    shtName = ActiveSheet.Name

    Dim arr() As String
    arr = VBA.Split(shtName, " ")

    xCount = UBound(arr)
    If xCount < 1 Then
        FindRoom = ""
    Else
        FindRoom = arr(xCount)
    End If
End Function

对不起，我知道这不是一个简单的答案问题，但任何帮助都会感激不已，即使它只是指向我正确的方向。

Answer 1

试试这个。我添加了工作表变量ws。这将工作表名称放在新工作簿的A列中，以及col B中的数据。我还为所有变量添加了声明。

Public Sub extractCol()

'Find FF&E Section, Add 3 rows and Identify relevant columns.

Dim rFind As Range, CRange As String, ERange As String, KRange As String, MRange As String
Dim ws As Worksheet
Dim NewBook As Workbook
Dim NumRange As Long

Set NewBook = Workbooks.Add ' Open new Workbook

For Each ws In ThisWorkbook.Worksheets
    With ws
        Set rFind = .Range("A:A").Find(What:="FF&E", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
        If Not rFind Is Nothing Then
            NumRange = rFind.Row + 3 ' Find FF&E line and add three
            CRange = "C" & NumRange & ":" & "C" & NumRange + 100 ' Define First 100 Lines in Column C
            ERange = "E" & NumRange & ":" & "E" & NumRange + 100 ' Define First 100 Lines in Column E
            KRange = "K" & NumRange & ":" & "K" & NumRange + 100 ' Define First 100 Lines in Column K
            MRange = "M" & NumRange & ":" & "M" & NumRange + 100 ' Define First 100 Lines in Column M

            Set range1 = Union(.Range(CRange), .Range(ERange), .Range(KRange), .Range(MRange)) ' Combine individual column ranges in to one selection
            range1.Copy ' Copy new combined range
            NewBook.Sheets(1).Range("B" & Rows.Count).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues ' Paste to new Workbook
            NewBook.Sheets(1).Range("A" & Rows.Count).End(xlUp)(2).Resize(range1.Rows.Count).Value = FindRoom(ws)
        End If
    End With
Next ws

End Sub

Function FindRoom(ws As Worksheet)

    shtName = ws.Name

    Dim arr() As String
    arr = VBA.Split(shtName, " ")

    xCount = UBound(arr)
    If xCount < 1 Then
        FindRoom = ""
    Else
        FindRoom = arr(xCount)
    End If
End Function

多个工作表上的数据提取

1 个答案: