将 100 多个不同 excel 工作簿中的数据提取到一个工作簿中

Question

我正在尝试从多个 excel 电子表格中提取某些数据。我正在尝试从 100 多张类似的 excel 工作表中整合数据。我想编写一个宏，允许我 select excel 电子表格，然后从给定的变量名称中提取所需的数据。

这就是我的

Public Sub CommandButton1_Click()

' Record job, modular code, multiple customers.

    Dim counter As Integer
    Dim PadPercentage As Single
    Dim Charactercounter As Integer
    Dim Date1 As String
    Dim Date2 As String
    Dim fd As FileDialog
    Dim vrtSelectedItem As Variant
    Dim Designcounter As Integer
    Dim Customer As String
    Dim Chemicals As String
    Dim Chemcounter As Integer
    Dim column As String
    Dim Sand As Integer
    Dim FindRow As Range




    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    Designcounter = -1


    With fd

        If .Show = -1 Then

            For Each vrtSelectedItem In .SelectedItems
                Designcounter = Designcounter + 1
                Workbooks.Open Filename:=vrtSelectedItem
                Sheets("Interval Summary").Select
                counter = 4
                Charactercounter = 1


'   Find and Copy date from Interval Summary.

                    Set FindRow = Cells.Find(What:="Date:", LookAt:=xlPart)
                    FindRow.Select
                    ActiveCell.Offset(0, 3).Select
                    Selection.Copy

                Windows("2014 GJ PE Engineering Job Logs - Iteration 2.xls").Activate
                Range("A" & CStr(counter)).Select


'   Search for first blank cell in column A.
                Do While ActiveCell.Value <> ""
                    counter = counter + 1
                    Range("A" & CStr(counter)).PasteSpecial xlPasteValuesAndNumberFormats
                Loop

'   Paste date onto job recording sheet.
                Range("A" & CStr(counter)).Select
                    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
                Selection.UnMerge
                Selection.NumberFormat = "m/d/yyyy"

' Record previous engineer name on job recording sheet.
                Range("B" & CStr(counter - 1)).Select
                Selection.Copy
                Range("B" & CStr(counter)).Select
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False

'   Copy customer name onto reporting sheet.
                ActiveWindow.ActivatePrevious
                Worksheets("Actual Design").Range("C1").Select
                Customer = ActiveCell.Value
                Selection.Copy
                ActiveWindow.ActivatePrevious
                Range("E" & CStr(counter)).Select
                ActiveSheet.Paste

'   Paste SO from design onto recording sheet.
                ActiveWindow.ActivateNext
                If Customer = "Noble Energy Inc." Then
                    Worksheets("Design").Range("O1").Select
                Else
                    Worksheets("Design").Range("Q1").Select
                End If
                Selection.Copy
                ActiveWindow.ActivatePrevious
                Range("C" & CStr(counter)).Select
                ActiveSheet.Paste
                Selection.UnMerge


    Call Lease_Pad_Well_Copy(Customer, counter)



'   Find and Copy Interval # from Well Data
                With Worksheets("Well Data")
                    Set FindRow = .Range("B:B").Find(What:="Date", LookIn:=xlValues)
                Windows("2014 GJ PE Engineering Job Logs.xls").Activate
                Range("A" & CStr(counter)).Select
                End With


'   Copy mid perf depth to reporting sheet.

                Worksheets("Actual").Range("C40").Select
                Selection.Copy
                ActiveWindow.ActivatePrevious
                Range("I" & CStr(counter)).Select
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False


'   Copy mid perf depth TVD to reporting sheet.

                Worksheets("Actual").Range("C40").Select
                Selection.Copy
                ActiveWindow.ActivatePrevious
                Range("I" & CStr(counter)).Select
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False


'   Copy Top perf depth to reporting sheet.

                Worksheets("Actual").Range("C40").Select
                Selection.Copy
                ActiveWindow.ActivatePrevious
                Range("I" & CStr(counter)).Select
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False


'   Copy Bottom perf depth to reporting sheet.

                Worksheets("Actual").Range("C40").Select
                Selection.Copy
                ActiveWindow.ActivatePrevious
                Range("I" & CStr(counter)).Select
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False


'   Copy formation name to reporting sheet.
                ActiveWindow.ActivateNext
                Worksheets("Design").Range("C3").Select
                Selection.Copy
                ActiveWindow.ActivatePrevious
                Range("J" & CStr(counter)).Select
                ActiveSheet.Paste


'   Copy fluid system.
                Range("K" & CStr(counter - 1)).Select
                Selection.Copy
                Range("K" & CStr(counter)).Select
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False

'   Copy crew from previous job.
                Range("L" & CStr(counter - 1)).Select
                Selection.Copy
                Range("L" & CStr(counter)).Select
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False

    If Customer = "Williams Prod RMT" Or Customer = "Chevron" Then
        Call Copy_Williams_Data(Customer, counter)
    End If

    If Customer = "Noble Energy Inc." Then
        Call Copy_Noble_Data(Customer, counter)
    End If

    If Customer = "Bill Barrett Corp." Then
        Call Copy_BBC(Customer, counter)
    End If

'   Copy slurry volume

                If Customer = "Williams Prod RMT" Then
                    ActiveWindow.ActivateNext
                    Sheets("Actuals").Select
                    Worksheets("Actuals").Range("H30").Select
                    Selection.Copy
                Else
                    ActiveWindow.ActivateNext
                    Sheets("Design").Select
                    Worksheets("Design").Range("H30").Select
                    Selection.Copy
                End If
                    ActiveWindow.ActivatePrevious
                    Range("S" & CStr(counter)).Select
                    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                        :=False, Transpose:=False



    '   Copy chemicals from design to Job recording sheet.
                ActiveWindow.ActivateNext
                Chemcounter = 78
                column = Chr(Chemcounter)
                Sheets("Well Data").Select
                Worksheets("Design").Range(column & "5").Select
                Do While ActiveCell.Value <> ""
                    If Chemcounter < 79 Then Chemicals = ActiveCell.Value
                    If Chemcounter > 78 Then Chemicals = Chemicals & ", " & ActiveCell.Value
                    Chemcounter = Chemcounter + 1
                    column = Chr(Chemcounter)
                    Worksheets("Well Data").Range(column & "5").Select
                Loop
                ActiveWindow.ActivatePrevious
                Range("P" & CStr(counter)).Select
                ActiveCell.Value = Chemicals



'   Switch back to and close design
                ActiveWindow.ActivateNext
                ActiveWorkbook.Save
                ActiveWindow.Close

            Next vrtSelectedItem
        End If
    End With

'   Format job log entries.
                ActiveWindow.ActivatePrevious
                Range("A" & CStr(counter - Designcounter) & ":AE" & CStr(counter)).Select
                Application.CutCopyMode = False
                With Selection.Font
                    .Name = "Arial"
                    .Size = 10
                    .Strikethrough = False
                    .Superscript = False
                    .Subscript = False
                    .OutlineFont = False
                    .Shadow = False
                    .Underline = xlUnderlineStyleNone
                    .ColorIndex = xlAutomatic
                End With
                Selection.Font.Bold = False
                Rows(CStr(counter) & ":" & CStr(counter)).Select
                Selection.RowHeight = 13.5



End Sub



Sub Lease_Pad_Well_Copy(Customer, counter)

    Dim Wellstrng As String
    Dim Pad As String
    Dim Wellpad As String
    Dim Lease As String
    Dim Well As String



    If Customer = "Williams Prod RMT" Or Customer = "Chevron" Or Customer = "Noble Energy Inc." Or Customer = "Bill Barrett Corp." Then
    '   Sort lease, well, and pad number and copy to reporting sheet.
                ActiveWindow.ActivateNext
                Worksheets("Design").Range("C2").Select
                If ActiveCell.Value <> "" Then
                    Wellstrng = ActiveCell.Value
                    Lease = Left(Wellstrng, CLng(InStr(Wellstrng, " ")) - 1)
                    Pad = Right(Wellstrng, Len(Wellstrng) - CLng(InStrRev(Wellstrng, "-")))
                    Wellpad = Left(Wellstrng, CLng(InStr(Wellstrng, "-")) - 1)
                    Well = Right(Wellpad, Len(Wellpad) - CLng(InStrRev(Wellpad, " ")))



                    If Customer = "Noble Energy Inc." Then

                        Wellstrng = ActiveCell.Value
                        Lease = Left(Wellstrng, CLng(InStr(Wellstrng, " ")) - 1)
                        Wellpad = Right(Wellstrng, Len(Wellstrng) - CLng(InStr(Wellstrng, " ")))
                        Wellpad = Left(Wellpad, Len(Wellpad) - CLng(InStrRev(Wellpad, " -")))
                        Pad = Left(Wellpad, CLng(InStr(Wellpad, "-")) - 1)
                        Wellpad = Left(Wellstrng, CLng(InStr(Wellstrng, " -")) - 1)
                        Well = Right(Wellpad, Len(Wellpad) - CLng(InStrRev(Wellpad, "-")))

                    End If

                    If Customer = "Bill Barrett Corp." Then
                        Wellstrng = ActiveCell.Value
                        Lease = Left(Wellstrng, CLng(InStr(Wellstrng, " ")) - 1)
                        Pad = Right(Wellstrng, Len(Wellstrng) - CLng(InStr(Wellstrng, "-")))
                        Wellpad = Left(Wellstrng, CLng(InStr(Wellstrng, "-")) - 1)
                        Well = Right(Wellpad, Len(Wellpad) - CLng(InStrRev(Wellpad, " ")))
                    End If



                    ActiveWindow.ActivatePrevious



    '   Copy lease name onto reporting sheet.
                    Range("F" & CStr(counter)).Select
                    ActiveCell.Value = Lease

    '   Copy well number onto reporting sheet.
                    Range("G" & CStr(counter)).Select
                    ActiveCell.Value = Well

    '   Copy pad onto reporting sheet.
                    Range("H" & CStr(counter)).Select
                    ActiveCell.Value = Pad
                    ActiveWindow.ActivateNext
                End If

    End If


End Sub




Sub Copy_BBC(Customer, counter)

    Dim Twosands As String
    Dim Sandint As Integer

    '   Copy average rate
            ActiveWindow.ActivateNext
            Sheets("Database").Select
            Worksheets("Database").Range("B16").Select
            Selection.Copy
            ActiveWindow.ActivatePrevious
            Range("M" & CStr(counter)).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False

    '   Copy average pressure
            ActiveWindow.ActivateNext
            Worksheets("Database").Range("B17").Select
            Selection.Copy
            ActiveWindow.ActivatePrevious
            Range("N" & CStr(counter)).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False

    '   Copy perfs open.
            ActiveWindow.ActivateNext
            Worksheets("Database").Range("G18").Select
            Selection.Copy
            ActiveWindow.ActivatePrevious
            Range("W" & CStr(counter)).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False

    '   Copy actual sand
            ActiveWindow.ActivateNext
            Worksheets("Database").Range("B26").Select
            Twosands = ActiveCell.Value
            Twosands = Twosands & " / "
            Worksheets("Database").Range("B28").Select
            Twosands = Twosands & ActiveCell.Value
            ActiveWindow.ActivatePrevious
            Range("Q" & CStr(counter)).Select
            ActiveCell.Value = Twosands


    '   Copy initial frac gradient
            ActiveWindow.ActivateNext
            Sheets("Database").Select
            Worksheets("Database").Range("B21").Select
            Selection.Copy
            ActiveWindow.ActivatePrevious
            Range("V" & CStr(counter)).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False

    '   Copy final frac gradient
            ActiveWindow.ActivateNext
            Worksheets("Database").Range("B23").Select
            Selection.Copy
            ActiveWindow.ActivatePrevious
            Range("Y" & CStr(counter)).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False

    '   Copy ISIP
            ActiveWindow.ActivateNext
            Worksheets("Database").Range("B20").Select
            Selection.Copy
            ActiveWindow.ActivatePrevious
            Range("U" & CStr(counter)).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False

    '   Copy ISDP
            ActiveWindow.ActivateNext
            Worksheets("Database").Range("B22").Select
            Selection.Copy
            ActiveWindow.ActivatePrevious
            Range("X" & CStr(counter)).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False



End Sub

Sub Copy_Williams_Data(Customer, counter)


    '   Copy average rate to reporting sheet.
                ActiveWindow.ActivateNext
                Sheets("Actuals").Select
                Worksheets("Actuals").Range("G63").Select
                Selection.Copy
                ActiveWindow.ActivatePrevious
                Range("M" & CStr(counter)).Select
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False

    '   Copy average pressure to reporting sheet.
                ActiveWindow.ActivateNext
                Worksheets("Actuals").Range("F63").Select
                Selection.Copy
                ActiveWindow.ActivatePrevious
                Range("N" & CStr(counter)).Select
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False

    '   Copy perfs open.
                ActiveWindow.ActivateNext
                Worksheets("Actuals").Range("D64").Select
                Selection.Copy
                ActiveWindow.ActivatePrevious
                Range("W" & CStr(counter)).Select
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False

    '   Copy actual sand
                ActiveWindow.ActivateNext
                Worksheets("Actuals").Range("D65").Select
                Selection.Copy
                ActiveWindow.ActivatePrevious
                Range("Q" & CStr(counter)).Select
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False

    '   Copy initial frac gradient
                ActiveWindow.ActivateNext
                Sheets("Actuals").Select
                Worksheets("Design").Range("D61").Select
                Selection.Copy
                ActiveWindow.ActivatePrevious
                Range("V" & CStr(counter)).Select
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False

    '   Copy final frac gradient
                ActiveWindow.ActivateNext
                Worksheets("Actuals").Range("D63").Select
                Selection.Copy
                ActiveWindow.ActivatePrevious
                Range("Y" & CStr(counter)).Select
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False

    '   Copy ISIP
                ActiveWindow.ActivateNext
                Worksheets("Actuals").Range("D60").Select
                Selection.Copy
                ActiveWindow.ActivatePrevious
                Range("U" & CStr(counter)).Select
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False

    '   Copy ISDP
                ActiveWindow.ActivateNext
                Worksheets("Actuals").Range("D62").Select
                Selection.Copy
                ActiveWindow.ActivatePrevious
                Range("X" & CStr(counter)).Select
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False

End Sub

Sub Copy_Noble_Data(Customer, counter)

    Dim SandColor As String
    Dim Sieve As String
    Dim Sandtemp As String
    Dim Sandtype As String

    '   Copy average rate to reporting sheet.
                ActiveWindow.ActivateNext
                Sheets("Actuals Design").Select
                Worksheets("Actual Design").Range("H63").Select
                Selection.Copy
                ActiveWindow.ActivatePrevious
                Range("M" & CStr(counter)).Select
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False

    '   Copy average pressure to reporting sheet.
                ActiveWindow.ActivateNext
                Worksheets("Actual Design").Range("H62").Select
                Selection.Copy
                ActiveWindow.ActivatePrevious
                Range("N" & CStr(counter)).Select
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False

   '   Copy Total perfs open.
                ActiveWindow.ActivateNext
                Worksheets("Actual Design").Range("E65").Select
                Selection.Copy
                ActiveWindow.ActivatePrevious
                Range("W" & CStr(counter)).Select
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False

     '   Copy actual sand.
                ActiveWindow.ActivateNext
                Worksheets("Design").Range("M61").Select
                Greensand = ActiveCell.Value
                Worksheets("Design").Range("M60").Select
                Whitesand = ActiveCell.Value & " / "
                Combinedsand = Whitesand & Greensand
                ActiveWindow.ActivatePrevious
                Range("Q" & CStr(counter)).Select
                ActiveCell.Value = Combinedsand


      '   Copy initial frac gradient
                ActiveWindow.ActivateNext
                Sheets("Interval Summart").Select
                Worksheets("Design").Range("E64").Select
                Selection.Copy
                ActiveWindow.ActivatePrevious
                Range("V" & CStr(counter)).Select
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False

    '   Copy final frac gradient
                ActiveWindow.ActivateNext
                Worksheets("Design").Range("H65").Select
                Selection.Copy
                ActiveWindow.ActivatePrevious
                Range("Y" & CStr(counter)).Select
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False

    '   Copy ISIP
                ActiveWindow.ActivateNext
                Worksheets("Design").Range("E63").Select
                Selection.Copy
                ActiveWindow.ActivatePrevious
                Range("U" & CStr(counter)).Select
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False

    '   Copy ISDP
                ActiveWindow.ActivateNext
                Worksheets("Design").Range("H64").Select
                Selection.Copy
                ActiveWindow.ActivatePrevious
                Range("X" & CStr(counter)).Select
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False


End Sub

Answer 1

这假设：

所有 sheet 都在一本书中
sheet #1 会记录收集到的数据
列 A 将包含 sheet 名称
列 B 将包含收集的值

运行这个小宏：

Sub FindingDollarsSpent()
    Dim i As Long
    Dim l As Long
    l = 1
    For i = 2 To Sheets.Count
        For Each r In Sheets(i).UsedRange
            If r.Value = "Dollars spent" Then
                With Sheets(1)
                    .Cells(l, 1).Value = Sheets(i).Name
                    .Cells(l, 2).Value = r.Offset(0, 1).Value
                End With
                l = l + 1
            End If
        Next r
    Next i
End Sub

将 100 多个不同 excel 工作簿中的数据提取到一个工作簿中

Pulling data from 100s of diiferent excel Workbooks into one workbook

excel

vba