AW: Archivierung von Daten
24.10.2013 14:28:23
Daten
Hallo Dennis,
füge im Archivtabellenblatt links von Spalte "Auftrag" eine Spalte ein für die Maschine.
Die Code für die Schaltfläche im Userform tauscht du dann durch den nachfolgenden Code aus.
Die Inhalte der kopierten Datensätze werden immer gleich gelöscht.
Nachdem alle Auftragsnummern abgearbeitet sind werden dann die Spalten je Maschine sortiert, so dass die leeren Zeilen ans Ende der Liste wandern.
mfg
Franz
Private Sub cmbArchivieren_Click()
Dim varMaschine, varAuftragNr As Variant, intNr As Integer, intCount As Integer
Dim wkbArchiv As Workbook, wksArchiv As Worksheet, lngZeileArchiv As Long
Dim rngBereich As Range, rngAuftragNr As Range, strAdresse1 As String
Dim lngSpalte As Long, lngZeile As Long
Dim bolOpen As Boolean
'In der Listbox selektierte Auftrags-Nummern ins Archiv kopieren
With Me.ListBox1
Application.ScreenUpdating = False
For intNr = 0 To .ListCount - 1
If .Selected(intNr) = True Then
varAuftragNr = .List(intNr, 0)
'ggf. Archiv-Datei öffnen
If wkbArchiv Is Nothing Then
'prüfen, ob Archivdatei schon geöffnet
For Each wkbArchiv In Application.Workbooks
If LCase(wkbArchiv.Name) = LCase(strDateiArchiv) Then
bolOpen = True 'Merker, dass die Archivdatei geöffnet ist
Exit For
End If
Next
If wkbArchiv Is Nothing Then
'Archivdatei öffnen
Set wkbArchiv = Application.Workbooks.Open( _
Filename:=ThisWorkbook.Path & "\" & strDateiArchiv, addtomru:=True)
End If
Set wksArchiv = wkbArchiv.Worksheets(1)
With wksArchiv
'letzte Zeile mit Auftragsnummer in Spalte 2 des Archivtabellenblattes
lngZeileArchiv = .Cells(.Rows.Count, 2).End(xlUp).Row
End With
End If
'Prüfen, ob Auftrag-Nr. schon archiviert ist
If lngZeileArchiv >= 2 Then
With wksArchiv
Set rngAuftragNr = .Range(.Cells(2, 2), .Cells(lngZeileArchiv, 2)).Find _
(What:=varAuftragNr, LookIn:=xlValues, lookat:=xlWhole)
End With
End If
If rngAuftragNr Is Nothing Then
With wksData
'Spalten mit Auftragsnummern nach Auftragsnummer durchsuchen
For lngSpalte = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column Step 12
'letzte Zeile mit Daten in Spalte
lngZeile = .Cells(.Rows.Count, lngSpalte).End(xlUp).Row
varMaschine = .Cells(2, lngSpalte).Value
If lngZeile >= 4 Then
'zu durchsuchenden Datenbereich setzen
Set rngBereich = .Range(.Cells(4, lngSpalte), _
.Cells(.Rows.Count, lngSpalte).End(xlUp))
'Auftrags-Nummer suchen im Bereich
Set rngAuftragNr = rngBereich.Find(What:=varAuftragNr, LookIn:=xlValues, _
lookat:=xlWhole)
If Not rngAuftragNr Is Nothing Then
strAdresse1 = rngAuftragNr.Address 'Zelladresse der 1. Fundstelle merken
Do
intCount = intCount + 1 'Zähler für Anzahl gefundene Zeilen
lngZeileArchiv = lngZeileArchiv + 1 'Zeilenzähler im Archiv erhöhen
lngZeile = rngAuftragNr.Row 'Zeile der Auftragsnumer in _
Produktionsmeldungen
'Daten ins Archiv kopieren nur Werte
wksArchiv.Cells(lngZeileArchiv, 1) = varMaschine
.Range(.Cells(lngZeile, lngSpalte), .Cells(lngZeile, lngSpalte + 11)).Copy
wksArchiv.Cells(lngZeileArchiv, 2).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
'kopierte Inhalte löschen
.Range(.Cells(lngZeile, lngSpalte), _
.Cells(lngZeile, lngSpalte + 11)).ClearContents
'Suche wiederholen
Set rngAuftragNr = rngBereich.FindNext(After:=rngAuftragNr)
If rngAuftragNr Is Nothing Then Exit Do
Loop Until strAdresse1 = rngAuftragNr.Address
End If
End If
Next lngSpalte
End With
Else
MsgBox "Auftrags-Nr. " & varAuftragNr & " ist bereits archiviert!", _
vbInformation + vbOKOnly, "A R C H I V I E R E N - Produktionsmeldungen"
End If
End If
Next
'gelöschte Bereiche umsortieren - leere Zeilen jeweils ans Ende der Liste
With wksData
For lngSpalte = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column Step 12
'letzte Zeile mit Daten in Spalte
lngZeile = .Cells(.Rows.Count, lngSpalte).End(xlUp).Row
If lngZeile > 4 Then
'Datenbereich zu Maschine
Set rngBereich = .Range(.Cells(4, lngSpalte), .Cells(lngZeile, lngSpalte + 11))
With rngBereich
.Sort Key1:=.Cells(1, 1), order1:=xlAscending, Header:=xlNo, _
Orientation:=xlSortColumns
End With
End If
Next lngSpalte
End With
Application.ScreenUpdating = True
MsgBox "Es wurden " & intCount & " Zeilen ins Archiv übertragen!", _
vbInformation + vbOKOnly, "A R C H I V I E R E N - Produktionsmeldungen"
If Not wkbArchiv Is Nothing Then
If bolOpen = True Then
'Speichern ohne schließen
wkbArchiv.Save
Else
'Speichern und schliessen
wkbArchiv.Close savechanges:=True
End If
End If
End With
Set rngBereich = Nothing: Set rngAuftragNr = Nothing
Set wkbArchiv = Nothing: Set wksArchiv = Nothing
Set wksData = Nothing
Unload Me
End Sub