AW: Nachfrage offen für bst
09.02.2007 16:25:29
bst
Hi chris b,
versuche das mal so ähnlich.
HTH, Bernd
--
Option Explicit
Sub Paaren()
Dim wsGepaart As Worksheet, lz_klassen As Long, lz_gepaart As Long
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
' Einfügen Teil 1 aus tabelle ("Importiere_Files_Klassen")
Set wsGepaart = Worksheets("Klassen mit Verwendung gepaart")
With wsGepaart
lz_gepaart = .Cells(Rows.Count, 1).End(xlUp).Row
If lz_gepaart > 1 Then
' Daten bereits vorhanden - alle löschen in Tabelle (Klassen mit Verwendung gepaart)
.Rows("2:" & lz_gepaart).Delete Shift:=xlUp
End If
End With
With Worksheets("Importiere_Files_Klassen")
lz_klassen = .Cells(Rows.Count, 1).End(xlUp).Row
'Spalten aus Tabelle ("Importiere_Files_Klassen") 1 zu 1 in Tabelle ("Klassen mit Verwendung gepaart") übernehmen
'Daten aus Tabelle("Importiere_Files_Klassen") Spalte 1 in Tabelle ("Klassen mit Verwendung gepaart") Spalte 1 kopieren
wsGepaart.Range("A2:A" & lz_klassen).Value = .Range("A2:A" & lz_klassen).Value
'Daten aus Tabelle("Importiere_Files_Klassen") Spalte 3 in Tabelle ("Klassen mit Verwendung gepaart") Spalte 2 kopieren
wsGepaart.Range("B2:B" & lz_klassen).Value = .Range("C2:C" & lz_klassen).Value
'Daten aus Tabelle("Importiere_Files_Klassen") Spalte 6 in Tabelle ("Klassen mit Verwendung gepaart") Spalte 3 kopieren
wsGepaart.Range("C2:C" & lz_klassen).Value = .Range("F2:F" & lz_klassen).Value
'Daten aus Tabelle("Importiere_Files_Klassen") Spalte 5 in Tabelle ("Klassen mit Verwendung gepaart") Spalte 4 kopieren
wsGepaart.Range("D2:D" & lz_klassen).Value = .Range("E2:E" & lz_klassen).Value
'Daten aus Tabelle("Importiere_Files_Klassen") Spalte 4 in Tabelle ("Klassen mit Verwendung gepaart") Spalte 5 kopieren
wsGepaart.Range("E2:E" & lz_klassen).Value = .Range("D2:D" & lz_klassen).Value
'Daten aus Tabelle("Importiere_Files_Klassen") Spalte 7 in Tabelle ("Klassen mit Verwendung gepaart") Spalte 6 kopieren
wsGepaart.Range("F2:F" & lz_klassen).Value = .Range("G2:G" & lz_klassen).Value
End With
'Aus Spalte 1 Punkte in Düsennummer entfernen
'Paaren Teil 1 aus Tabelle ("Importiere_Files_Klassen") - mit " Spalten aus Tabelle ("Importiere_Files_Verwendung")
Call doPaaren(wsGepaart, Worksheets("Importiere_Files_Verwendung"))
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Worksheets("Start").Select
Range("L3") = "Schritt 3 gestartet am " & Date & " um " & Time
MsgBox ("abgeschlossen"), vbInformation, "Fertig"
End Sub
Private Sub doPaaren(wsVerwendung As Worksheet, wsGepaart As Worksheet)
Dim lngMaxRows As Long, i As Long, lngIndex As Long, strKey As String
Dim dicIndex As Object, arVerwendung, arGepaartIndex, arGepaartWerte
Set dicIndex = CreateObject("scripting.dictionary")
With wsVerwendung
lngMaxRows = IIf(Len(.Cells(.Rows.Count, 1)), .Rows.Count, .Cells(.Rows.Count, 1).End(xlUp).Row)
arVerwendung = .Range(.Cells(1, 3), .Cells(lngMaxRows, 16))
For i = 1 To lngMaxRows
strKey = arVerwendung(i, 1)
If dicIndex.Exists(strKey) Then
Debug.Print "Zeile: "; i; " Key existiert bereits: "; strKey
Else
dicIndex.Add strKey, i
End If
Next
End With
With wsGepaart
lngMaxRows = IIf(Len(.Cells(.Rows.Count, 1)), .Rows.Count, .Cells(.Rows.Count, 1).End(xlUp).Row)
arGepaartIndex = .Range(.Cells(1, 1), .Cells(lngMaxRows, 1))
arGepaartWerte = .Range(.Cells(1, 7), .Cells(lngMaxRows, 8))
For i = 1 To lngMaxRows
strKey = CStr(arGepaartIndex(i, 1))
If dicIndex.Exists(strKey) Then
lngIndex = dicIndex(strKey)
arGepaartWerte(i, 1) = arGepaartWerte(i, 1) & Chr(10) & arVerwendung(lngIndex, 9)
arGepaartWerte(i, 2) = arGepaartWerte(i, 2) & Chr(10) & arVerwendung(lngIndex, 14)
End If
Next
.Range(.Cells(1, 7), .Cells(lngMaxRows, 8)) = arGepaartWerte
End With
dicIndex.RemoveAll
Set dicIndex = Nothing
End Sub