AW: Zeilen löschen funktioniert nur teilweise
31.12.2016 23:39:02
Oisse
Hallo Gerd und danke für deine Antwort.
Ich kann gerne den ganzen Code zeigen.
Ich hoffe, er ist nicht allzu unübersichtlich:
Private Sub ArtikelNachVerkauft_Click()
Dim c As Range
Dim wsTarget As Worksheet
Dim firstAddress As String
Dim arrFiles As Variant
Dim arrSheets As Variant
Dim i As Integer
Dim int_Counter As Integer
Dim int_Column As Integer
Dim rng_Row As Range
Dim wkb As Workbook
Dim wks_Art As Worksheet
Dim AusW As Variant
Dim WBAusW As Workbook
Dim wks_Verk As Worksheet 'Zieldatei ist das Worksheet "Auswertung Verkauft"
Dim sPfad As String
AusW = ThisWorkbook.Path & "\Auswertung Artikelliste.xlsm"
AusW = CStr(AusW)
If AusW = "Falsch" Then Exit Sub
'öffnen der ausgewählten Datei
Set WBAusW = Workbooks.Open(AusW)
'Screenflicker unterdrücken
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set wkb = ThisWorkbook
Set wks_Art = wkb.Worksheets("Artikel")
Set wks_Verk = WBAusW.Worksheets("Verkauft")
wks_Art.Activate
Call Endung.Ende 'Endung für Bezahlt
UserForm6.Show
strFinde = Label1
If Right$(Label1, 2) = Endung.Endung Then
arrFiles = Array(wkb)
arrSheets = Array(wks_Art)
'Screenflicker unterdrücken
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = 0 To UBound(arrFiles)
With wks_Art.Range("X:X")
Set c = .Find(Label1, LookIn:=xlValues, LookAt:=xlWhole)
If c Is Nothing Then 'Wenn die Vorgangsnummer nicht vorhanden oder falsch ist, _
dann den Vorgang abbrechen
If MsgBox("Diese Vorgangsnummer ist nicht vorhanden", vbOKOnly, "Achtung") = _
vbOK Then
Unload UserForm1
Exit Sub
End If
End If
If Not c Is Nothing Then
firstAddress = c.Address
Range(c.Address).Select 'Die Zeile in der der zu suchende Wert ist _
markieren
Do
Union(Selection, Range(c.Address)).Select 'alle Zeilen in denen der zu _
suchende Wert vorkommt markieren
'Finde den nächsten passenden Eintrag
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address firstAddress
End If
End With
Next
'Screenflicker unterdrücken
Application.DisplayAlerts = True
Application.ScreenUpdating = True
'Ab hier erfolgt dann das Auslesen der Daten aus den entsprechenden Zellen der oben _
selektierten Zeilen
'und die Zuordnung in die Tabelle Verkauft
For Each rng_Row In Selection.Rows
slng = wks_Verk.Cells(Rows.Count, 1).End(xlUp).Row
wks_Art.Rows(rng_Row.Row).Copy: wks_Verk.Rows(slng + 1).Insert Shift:=xlUp
Next
'Löschen der bereits in "Verkauft" befindlichen Artikel aus der Tabelle "Artikel"
wks_Art.Activate
wks_Art.Rows(rng_Row.Row).Delete
'In der Tabelle "Verkauft" werden die Zeilen auf automatische Zeilenhöhe gesetzt, die Tabelle _
erweitert und doppelte Werte gelöscht
With wks_Verk
.Activate
.Rows("2:" & slng).AutoFit
.Range("A1:AB" & slng).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, _
13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28), Header:=xlYes
End With
'*********************************************************************************************** _
'Ende der Eintragung in Tabelle "Verkauft"
'*********************************************************************************************** _
Unload UserForm1
Exit Sub
End If
wks_Art.Activate
'*********************************************************************************************** _
'Wenn die Endung noch nicht vorhanden ist für Bezahlt, wird gefragt ob bezahlt ist
'Wenn Ja, dann wird die Endung gesetzt und das Kopieren wird vorgenommen, bei Nein wird _
abgebrochen
'*********************************************************************************************** _
If Right$(Label1, 2) Endung.Endung Then
If MsgBox("Sind die Artikel bereits bezahlt?" & Chr(10) & _
"Wenn nicht, dürfen die Artikel nicht ausgegeben werden" & Chr(10) & _
"Der Vorgang wird dann abgebrochen", vbYesNo, "Vorsicht!") = vbYes Then
'*********************************************************************************************** _
' Eintragung in die Tabelle "Verkauft"
'*********************************************************************************************** _
If Right$(Label1, 2) = Endung.Endung Then
Label1 = Label1
End If
arrFiles = Array(wkb)
arrSheets = Array(wks_Art)
'Screenflicker unterdrücken
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = 0 To UBound(arrFiles)
With wks_Art.Range("X:X")
Set c = .Find(Label1, LookIn:=xlValues, LookAt:=xlWhole)
If c Is Nothing Then 'Wenn die Vorgangsnummer nicht vorhanden oder falsch ist, _
dann den Vorgang abbrechen
If MsgBox("Diese Vorgangsnummer ist nicht vorhanden", vbOKOnly, "Achtung") = _
vbOK Then
Unload UserForm1
Exit Sub
End If
End If
If Not c Is Nothing Then
firstAddress = c.Address
Range(c.Address).Select 'Die Zeile in der der zu suchende Wert ist _
markieren
Do
Union(Selection, Range(c.Address)).Select 'alle Zeilen in denen der zu _
suchende Wert vorkommt markieren
'Finde den nächsten passenden Eintrag
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address firstAddress
End If
End With
Next
'Screenflicker unterdrücken
Application.DisplayAlerts = True
Application.ScreenUpdating = True
'Ab hier erfolgt dann das Auslesen der Daten aus den entsprechenden Zellen der oben _
selektierten Zeilen
'und die Zuordnung in die Tabelle Verkauft
For Each rng_Row In Selection.Rows
slng = wks_Verk.Cells(Rows.Count, 1).End(xlUp).Row
wks_Art.Rows(rng_Row.Row).Copy: wks_Verk.Rows(slng + 1).Insert Shift:=xlUp
wks_Verk.Range("X" & slng + 1).Value = Label1 & Endung.Endung
Next
'Löschen der bereits in "Verkauft" befindlichen Artikel aus der Tabelle "Artikel"
'wks_Art.Activate
wks_Art.Rows(rng_Row.Row).Delete
'For L = Selection.Rows.Count To 1 Step -1
'Selection.Rows(L).Delete
'Next
'For Each rng_Row In Selection
' wks_Art.Rows(rng_Row.Row).Delete Shift:=xlUp
'Next
'In der Tabelle "Verkauft" werden die Zeilen auf automatische Zeilenhöhe gesetzt, die Tabelle _
erweitert und doppelte Werte gelöscht
With wks_Verk
.Activate
.Rows("2:" & slng).AutoFit
'.ListObjects(1).Resize .Range(.Cells(1, 1), .Cells(slng + 1, "AA"))
.Range("A1:AB" & slng).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, _
13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28), Header:=xlYes
End With
'*********************************************************************************************** _
'Ende der Eintragung in Tabelle "Verkauft"
'*********************************************************************************************** _
Unload UserForm1
End If
End If
End Sub
Gruß Oisse