Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1444to1448
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Tabellen zusammenfügen

Tabellen zusammenfügen
09.09.2015 15:26:47
Bianca
Hallo Leute,
bitte um Hilfe!
folgendes Problem:
2 Tabellen (Übersicht und Detail)
im ersten Sheet steht eine Übersicht aller Antragsnummern (1000-xxxx)
im zweiten Sheet stehen alle Bestellungen zu diesen Antragsnummern.
Ich möchte beide zusammenspielen und zwar so, dass unter der Zeile mit Auftragsnummer 1000 alle Bestellungen von 1000 eingefügt werden.
Am besten per Makro, da die Bestelldatei jede Woche länger wird.
Bitte, Bitte um Hilfe!!
Danke Bianca
Bsp. ist anbei
https://www.herber.de/bbs/user/100101.xlsx

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Tabellen zusammenfügen
15.09.2015 10:31:30
Bianca
Hallo Sepp,
ich hoffe du siehst das noch, denn eine Frage hätte ich noch:
Wie muss ich den Code umschreiben, wenn die Auftragsnummer nicht in Spalte D steht, sondern beispielsweise in Spalte Z und alles bis dahin kopiert werden soll?
Ich hab es selber versucht und komme leider nicht dahinter!
lg Bianca

Anzeige
AW: Tabellen zusammenfügen
15.09.2015 19:35:07
Sepp
Hallo Bianca,
ich habe in den Code ein paar Konstanten eingearbeitet, mit denen du die Spalten vorgeben kannst.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub zusammenfassung()
Dim vntAuflauf As Variant, vntOut() As Variant
Dim objSh As Worksheet, vntRet As Variant, rng As Range
Dim lngI As Long, lngAnswer As Long, lngR As Long, lngC As Long, lngInsert As Long
Dim strFirst As String

Const cSheetName As String = "Zusammenfassung"
Const cLngSearchColumn As Long = 4 'Spalte in "Bestellungen" die durchsucht wird - Anpassen!
Const cLngCriteriaColumn As Long = 2 'Spalte in der die Nummern in "Auflauf" stehen - Anpassen!
Const cLngLastColumn As Long = 3 'Spalte bis zu der die Daten aus "Bestellungen" übertragen werden sollen - Anpassen!

On Error GoTo ErrExit

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  .Calculation = xlManual
  .DisplayAlerts = False
End With

If Not SheetExist(cSheetName) Then
  Set objSh = Worksheets.Add(After:=Sheets(Sheets.Count))
  objSh.Name = cSheetName
Else
  lngAnswer = MsgBox("Ausgabe auf Tabelle '" & cSheetName & "'" & vbTab & "= [JA]" & vbLf & _
    "Ausgabe auf neuem Tabellenblatt" & vbTab & "= [NEIN]", vbQuestion + vbYesNo)
  If lngAnswer = 7 Then
    Set objSh = Worksheets.Add(After:=Sheets(Sheets.Count))
    objSh.Name = cSheetName & Format(Now, "_ddmmyy_hhmmss")
  ElseIf lngAnswer = 6 Then
    Set objSh = Sheets(cSheetName)
    objSh.UsedRange.Clear
  Else
    Exit Sub
  End If
End If

With Sheets("Auflauf")
  vntAuflauf = .Range("A2:H" & Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row))
  .Rows(1).Copy objSh.Range("A1")
End With

lngInsert = 2

With Sheets("Bestellungen")
  For lngI = 1 To UBound(vntAuflauf, 1)
    lngR = 1
    strFirst = ""
    Set rng = Nothing
    vntRet = Application.CountIf(.Columns(cLngSearchColumn), vntAuflauf(lngI, cLngCriteriaColumn))
    Redim vntOut(1 To vntRet + 1, 1 To Application.Max(cLngLastColumn, UBound(vntAuflauf, 2)))
    For lngC = 1 To UBound(vntAuflauf, 2)
      vntOut(1, lngC) = vntAuflauf(lngI, lngC)
    Next
    If vntRet > 0 Then
      Set rng = .Columns(cLngSearchColumn).Find(What:=vntAuflauf(lngI, cLngCriteriaColumn), LookAt:=xlWhole, LookIn:=xlValues, MatchCase:=False, SearchFormat:=False, After:=.Cells(1, 4))
      If Not rng Is Nothing Then
        strFirst = rng.Address
        Do
          lngR = lngR + 1
          For lngC = 1 To cLngLastColumn
            vntOut(lngR, lngC) = .Cells(rng.Row, lngC).Value
          Next
          Set rng = .Columns(cLngSearchColumn).FindNext(rng)
        Loop While Not rng Is Nothing And rng.Address <> strFirst
      End If
    End If
    objSh.Cells(lngInsert, 1).Resize(UBound(vntOut, 1), UBound(vntOut, 2)) = vntOut
    objSh.Cells(lngInsert, 1).Resize(1, UBound(vntOut, 2)).Font.Bold = True
    lngInsert = lngInsert + UBound(vntOut, 1) + 1
  Next
End With

objSh.Columns.AutoFit
objSh.Activate

ErrExit:

With Err
  If .Number <> 0 Then
    MsgBox "Fehler in Prozedur:" & vbTab & "'zusammenfassung'" & vbLf & String(60, "_") & _
      vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
      "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
      .Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
      "VBA - Fehler in Prozedur - zusammenfassung"
    .Clear
  End If
End With

On Error GoTo 0

With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .Calculation = xlAutomatic
  .DisplayAlerts = True
  .StatusBar = False
End With

Set objSh = Nothing
Set rng = Nothing
End Sub


Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
Dim wks As Object
On Error GoTo ERRORHANDLER
If Wb Is Nothing Then Set Wb = ThisWorkbook
For Each wks In Wb.Sheets
  If LCase(wks.Name) = LCase(sheetName) Then SheetExist = True: Exit Function
Next
ERRORHANDLER:
SheetExist = False
End Function


Gruß Sepp

Anzeige
AW: Tabellen zusammenfügen
16.09.2015 10:11:36
Bianca
Vielen Dank für deine Hilfe!!
lg Bianca

AW: Tabellen zusammenfügen
15.09.2015 09:17:13
Bianca
Vielen Dank Sepp!
Hast mich gerettet :)

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige