Question

我有7个工作表，其中包含有关我大学房间项目的信息，我需要在每张工作表中搜索某些信息，如果它是一个计算机池。我想将所有池复制到一个额外的工作表，然后可以更新该工作表中的信息，它会自动更新orignal工作表。

我的主要问题是我真的不知道如何调用这样的更新函数。我在底部附加了代码，将所有房间复制到专用工作表。提前谢谢

Option Explicit

Sub Start()
Dim Suche As String
Dim Blatt1 As String
Dim Blatt2 As String
Dim Blatt3 As String
Dim Blatt4 As String
Dim Blatt5 As String
Dim Blatt6 As String
Dim Blatt7 As String
Dim Result As String


Blatt1 = "1. Stock MZG"
Blatt2 = "5. Stock MZG"
Blatt3 = "6. Stock MZG"
Blatt4 = "7. Stock MZG"
Blatt5 = "8. Stock MZG"
Blatt6 = "1. Stock OEC"
Blatt7 = "2. Stock OEC"


Suche = "Poolraum"
If Len(Suche) Then
    Result = "Es wurde(n) " & AuswahlKopieren(Suche, True, Blatt1) & " Zeile(n) aus '" & Blatt1 & "' kopiert!"
    Result = Result & vbCrLf & "Es wurde(n) " & AuswahlKopieren(Suche, True, Blatt2) & " Zeile(n) aus '" & Blatt2 & "' kopiert!"
    Result = Result & vbCrLf & "Es wurde(n) " & AuswahlKopieren(Suche, True, Blatt3) & " Zeile(n) aus '" & Blatt3 & "' kopiert!"
    Result = Result & vbCrLf & "Es wurde(n) " & AuswahlKopieren(Suche, True, Blatt4) & " Zeile(n) aus '" & Blatt4 & "' kopiert!"
    Result = Result & vbCrLf & "Es wurde(n) " & AuswahlKopieren(Suche, True, Blatt5) & " Zeile(n) aus '" & Blatt5 & "' kopiert!"
    Result = Result & vbCrLf & "Es wurden(n) " & AuswahlKopieren(Suche, True, Blatt6) & " Zeile(n) aus '" & Blatt6 & "' kopiert!"
    Result = Result & vbCrLf & "Es wurde(n) " & AuswahlKopieren(Suche, True, Blatt7) & " Zeile(n) aus '" & Blatt7 & "' kopiert!"
    MsgBox (Result)
End If

End Sub

Function AuswahlKopieren(SuchStr As String, Optional Ganz As Boolean = False, Optional Arbeitsblattname As String) As Integer

Dim WSq             As Worksheet
Dim WSz             As Worksheet
Dim SuchColRng      As Range
Dim FRng            As Range
Dim CRng            As Range
Dim CRangeCustom    As Range
Dim FirstAdr        As String
Dim CArr            As Variant

Set WSq = Worksheets(Arbeitsblattname)
Set SuchColRng = WSq.Range("E:E")
Set CRangeCustom = WSq.Range("A:G")
Set WSz = Worksheets("Poolräume")

With SuchColRng
    If Ganz Then
        Set FRng = .Find(SuchStr, LookIn:=xlValues, LookAt:=xlWhole)
    Else
        Set FRng = .Find(SuchStr, LookIn:=xlValues, LookAt:=xlPart)
    End If
    If Not FRng Is Nothing Then
        FirstAdr = FRng.Address
        Do
            If CRng Is Nothing Then
                Set CRng = WSq.Rows(FRng.Row)
            Else
                Set CRng = Union(WSq.Rows(FRng.Row), CRng)
                'MsgBox ("WSq.Rows(FRng.Row): " + WSq.Rows(FRng.Row))
            End If
            Set FRng = .FindNext(FRng)
        Loop While Not FRng Is Nothing And FRng.Address <> FirstAdr
    End If
End With
If Not CRng Is Nothing Then
    Set CRng = Intersect(CRng, CRangeCustom)
    CRng.Copy
    WSz.Cells(WSz.Cells(WSz.Rows.Count, SuchColRng.Column).End(xlUp).Row + 1, 1).PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    AuswahlKopieren = CRng.Cells.Count / CRng.Rows(1).Cells.Count
    MsgBox ("CRng.Cells.Count: " & CRng.Cells.Count & " CRng.Rows(1).Cells.Count: " & CRng.Rows(1).Cells.Count)
Else
    AuswahlKopieren = 0
End If
End Function

Function WSExists(ByVal WSName As String) As Boolean
Dim WS As Worksheet
For Each WS In Worksheets
    If WS.Name = WSName Then
        WSExists = True
        Exit For
    End If
Next
End Function

Answer 1

我没有看到任何其他方式而不是复制到您提到的其他工作表，不仅是池信息，还有从中获取此池的参考（工作表，单元格）。之后，您可以创建一个单独的宏来放回任何更改，因为您将知道它的拍摄地点。希望这会有所帮助。

Answer 2

我知道这不是您所询问的内容，但您可以通过将Blatt1 ... Blatt7放入这样的数组中来使这段代码更容易使用：

Function BlattArray() as Variant
 Dim BlattStr as String
 BlattStr="1. Stock MZG,5. Stock MZG,6. Stock MZG,7. Stock MZG,8. Stock MZG,1. Stock OEC,2. Stock OEC"
 BlattArray=Split(BlattStr,",")
End Function

然后您可以将Result构建为：

Result=""
For Each Blatt in BlattArray
 Result = Result & vbCrLf & "Es wurde(n) " & AuswahlKopieren(Suche, True, Cstr(Blatt)) & " Zeile(n) aus '" & Blatt & "' kopiert!"
Next

这样，无论何时添加其他工作表，只需将其名称添加到BlattStr字符串。

同时更新2个单元格的值

2 个答案: