Mehrere Zellen in mehreren Arbeitsblättern suchen und dann einen anderen Zellenwert in einem Übersichtsblatt kopieren

Question

Ich habe eine Arbeitsmappe mit 4 Arbeitsblättern, die alle Daten in Zeile 5 enthalten, und zwar in Spalte D. In der Zelle neben dem Datum die Person wird entweder 'ET', 'LT', 'EG', '1ET', '2LT' eingeben oder sie lassen es leer.

Ich lese gerade, wie VBA im Moment funktioniert, aber ich habe gerade so sehr neu damit begonnen.

Ich habe dies so weit:

Sub test() 
    Dim summarySheet As Worksheet 
    Dim sh As Worksheet 
    Dim j As Integer 

     'change "Summary" to the sheet name that is true for you' 
     Set summarySheet = ThisWorkbook.Worksheets("Summary") 

     'number of first row where need to paste in summary sheet' 
     j = 2 

     'loop throught all sheets' 
     For Each sh In ThisWorkbook.Worksheets 
      If sh.Name <> summarySheet.Name Then 
       summarySheet.Range("B" & j & ":AF" & j).Value = _ 
       sh.Range("D5:AH5").Value 
       j = j + 1 
      End If 
     Next 
End Sub 

Er zeigt alle Datenblätter, aber was ich brauche, ist, wenn es entweder ET oder LT in Zeile eingetragen 5 neben dem Datum dann die entsprechenden Daten hinzufügt von Zeile 37 in ein Übersichtsblatt. Wenn es nur die Zahl ist, dann ist es, dass zu überspringen und die nächsten ET oder LT

EG 
    Sheet 1 
Row 5 1ET 2LT 3ET 4 5 6 7ET 8ET   
    =========================== 
Row 37 16 32 2   45 67 

Sheet 2 

Row 5 1 2 3LT 4ET 5ET 6LT 7 8LT 
     =========================== 
Row 37  23 33 13 22  34 


    SUMMARY SHEET 

     ET LT 
    1 16 
    2  32 
    3 2 23 
    4 33 
    5 13 
    6   
    7 45 
    8 67 34 
    9   
    Etc 

Answer 1

Ich verstehe nicht ganz das finden, was Sie zu tun versuchen. Ihr Code kopiert den Bereich genau in das Übersichtsblatt, aber es sieht so aus, als würde das Ergebnis Sie transponieren - die Zahlen/Daten werden in den Zeilen anstatt in den Zeilen angezeigt. Sie sagen auch "Dates", aber haben die Nummern 1-9 auf dem Summary Sheet und haben die Nummern 1-9 auf Sheet1 und Sheet2. Ich kann auch nicht sagen, welche Spalte die "entsprechenden" Werte in Zeile 37 sind.

Daher kann dieser Code nicht genau für Sie arbeiten, da er auf den Annahmen beruht, dass 1) Sie nicht wollen, D5: AH5 von jedem Blatt genau auf dem Übersichtsblatt eingefügt; 2) da sie die einzigen sind, die Sie als Kriterien nennen, sind "ET" und "LT" die einzigen Codes neben "Daten", die Ihnen wichtig sind; 3) der Wert in Zeile 37 ist in der gleichen Spalte wie das "Datum"; 4) die "1ET" und "2LT" in Ihren Daten repräsentieren eine "1" in D5, "ET" in E5, "2" in F5, "LT" in G5, und so weiter; 5) Da Sie die Zahlen 1 bis 9 verwendet haben, wird die Zeile zum Einfügen des Wertes aus Zeile 37 bestimmt, indem das "Datum" genommen und 1 addiert wird. Wenn Sie tatsächliche Daten haben, müssen Sie Ihre Logik für pasteRow ändern.

Sub test() 
    Dim summarySheet As Worksheet 
    Dim sh As Worksheet 
    Dim searchRng As Range 
    Dim dateCell As Range 
    Dim pasteCol As Integer 
    Dim copyRow As Integer 
    Dim pasteRow as integer 

    'change "Summary" to the sheet name that is true for you' 
    Set summarySheet = ThisWorkbook.Worksheets("Summary") 

    'the "corresponding row" to copy 
    copyRow = 37 

    'loop throught all sheets' 
    For Each sh In ThisWorkbook.Worksheets 
     If sh.Name <> summarySheet.Name Then 
      'set the range that we are using 
      Set searchRng = sh.Range("D5:AH5") 

      For Each cell In searchRng 
       'loop through the range and check if it has the desired key value 
       If cell.Value = "ET" Or cell.Value = "LT" Then 
        'set which column on SummarySheet will get the value 
        If cell.Value = "ET" Then 
         'column B, ie column #2 
         pasteCol = 2 
        ElseIf cell.Value = "LT" Then 
         'column C, ie column #3 
         pasteCol = 3 
        End If 
        'set the cell containing the date - assumes is to the left of our key value cell 
        Set dateCell = cell.Offset(0, -1) 
        'set row # to paste to, ie if the value in dateCell is 9, then paste to row 10 
        pasteRow = dateCell.Value + 1 
        'set the value on summarySheet using the value in dateCell + 1 for our row number 
        'and dateCell's column with copyRow to get our "corresponding" value 
        summarySheet.Range(Cells(pasteRow, pasteCol).Address).Value = _ 
          sh.Range(Cells(copyRow, dateCell.Column).Address) 
       End If 
      Next cell 
     End If 
    Next 
End Sub 

EDITED basierend auf neuen Informationen aus tatsächlichen Tabelle:

Sub test() 
    Dim summarySheet As Worksheet 
    Dim sh As Worksheet 
    Dim searchRng As Range 
    Dim dateNum As Integer 
    Dim pasteCol As Integer 
    Dim copyRow As Integer 
    Dim pasteRow As Integer 
    Dim c As Range 
    Dim oldVal As Integer 

    'change "Summary" to the sheet name that is true for you' 
    Set summarySheet = ThisWorkbook.Worksheets("Summary") 
    'clear current value on summarySheet 
    summarySheet.Range("C3:D33").Value = "" 

    'loop throught all sheets' 
    For Each sh In ThisWorkbook.Worksheets 
     If sh.Name <> summarySheet.Name Then 
      'set the range that we are using 
      Set searchRng = sh.Range("D5:AH5") 

      'the "corresponding row" to copy 
      With sh.Range("C:C") 
       Set c = .Find("Number of staff") 
       If Not c Is Nothing Then 
        copyRow = c.Row 
       End If 
      End With 

      For Each cell In searchRng 
       'loop through the range and check if it has the desired key value 
       If cell.Value Like "*ET" Or cell.Value Like "*LT" Then 
        'set which column on SummarySheet will get the value 
        If cell.Value Like "*ET" Then 
         'column C, so column #3 
         pasteCol = 3 
        ElseIf cell.Value Like "*LT" Then 
         'column D, so column #4 
         pasteCol = 4 
        End If 
        'get the date from the cell 
        dateNum = Val(cell.Value) 
        If dateNum = 0 Then 
         MsgBox "Sheet " & sh.Name & " cell " & cell.Address & " is missing date. Please fill in and run again." 
         Exit Sub 
        End If 
        'set row # to paste to, ie if the value in dateCell is 9, then paste to row 11 
        pasteRow = dateNum + 2 
        'set the value on summarySheet using cell's column with copyRow to get our "corresponding" value 
        oldVal = summarySheet.Range(Cells(pasteRow, pasteCol).Address).Value 
        summarySheet.Range(Cells(pasteRow, pasteCol).Address).Value = _ 
          sh.Range(Cells(copyRow, cell.Column).Address).Value + oldVal 
       End If 
      Next cell 
     End If 
    Next 
    MsgBox "Complete" 
End Sub 

Answer 2

Option Explicit 
Private Sub Worksheet_Activate() 
Dim r As Range, rng As Range, snRow As Range, x As Integer 
ActiveSheet.Range("C4:AG5").ClearContents 
For x = 1 To Sheets.Count 
If Sheets(x).Name <> "Summary" Then 
    With Sheets(Sheets(x).Name) 
     With .Range("C:C") 
      Set snRow = .Find("Number of staff", LookIn:=xlValues, lookat:=xlWhole) 
     End With 
     Set rng = .Range("D5", "AH5") 
     For Each r In rng 
      If InStr(1, r.Value, "LT") > 0 Then 
       Sheets("Summary").Cells(5, r.Column - 1) = .Cells(snRow.Row, r.Column).Value 
      ElseIf InStr(1, r.Value, "ET") > 0 Then 
       Sheets("Summary").Cells(4, r.Column - 1) = .Cells(snRow.Row, r.Column).Value 
      End If 
     Next 
    End With 
End If 
Next 
End Sub 

Dadurch wird erreicht, alles, was ich mit der Zusammenfassung geht über die Seite statt vertikal wollte.