0

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

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

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
4

2 回答 2

0

我知道这不是您要问的，但是您可以通过将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字符串中。

于 2013-04-18T18:46:36.777 回答
0

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

于 2013-04-18T09:23:31.717 回答