Nach Kriterium markieren

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
Bild

Betrifft: Nach Kriterium markieren
von: RalfH
Geschrieben am: 05.11.2003 19:11:13

Hallo zusammen,

ich habe folgendes Problem:

Ich habe eine Tabelle mit 3 Spalten (Kundennummer, Artikelnummer, Menge) in der eine Kundennummer mehrfach vorkommen kann.

Jetzt möchte ich die Kundennummer in ein Rechnungssheet übertragen, anschließend sollen die zur Kundennummer passenden Artikelnummern und Menge markiert, in das Rechnungssheet übertragen und anschließend alle Zeilen gelöscht werden.

Wie kann ich das ganze als Makro automatisiert laufen lassen.


Schon mal besten Dank

Gruss Ralf

Bild


Betrifft: AW: Nach Kriterium markieren
von: Peter
Geschrieben am: 05.11.2003 19:41:28

Hallo Ralf,

mit einer Beispiel Mappe wäre es einfacher!

Gruss Peter


Bild


Betrifft: AW: Nach Kriterium markieren
von: RalfH
Geschrieben am: 05.11.2003 20:00:08

Hallo Peter,

ich habe die Datei auf den Server geladen.

https://www.herber.de/bbs/user/1760.xls

Du kannst Dir ja mal das Makro2 anschauen, da habe ich schon mal probiert.
Bis auf das löschen der Zeilen funktioniert es auch.

Bevor ich es vergesse, vor dem löschen der Zeilen soll noch mit "call..." ein vorliegendes Druckmakro aufgerufen werden.

Schon mal besten Dank

Gruß
Ralf


Bild


Betrifft: AW: Nach Kriterium markieren
von: Andi_H
Geschrieben am: 05.11.2003 21:13:01

Hi Ralf,

ich habs nicht geschafft deine Datei zu laden, hab aber mal gebastelt wie ich das machen würde:

Tabelle Kunden und ein Blatt Namens Rechnung
Kundennummer in Spalte A
ArtNr in B und Menge in C

übertragen wird das ganze in Rechnungen, hab einfach mal irgendwelche zellen genommen, mußt du halt anpassen.
Hier der Code


Sub Test()
Dim Lrow As Long
Dim kdnr As String
Dim kunden, rechnung As Worksheet
Set rechnung = Sheets("Rechnung") ' sheetnamen anpassen!!!
Set kunden = Sheets("Kunden") '!!!!
kdnr = InputBox("Bitte Kundennummer eingeben") ' Kundennummer abfragen
If IsEmpty(kunden.Cells(65536, 1)) Then 
    Lrow = kunden.Cells(65536, 1).End(xlUp).Row ' letzte zelle ermitteln
    
Else
    Lrow = 65536
End If
Dim x, y As Integer
x = 5 ' x ist die Zeilennummer im Sheet Rechnung
y = 2
For i = Lrow To 2 Step -1 ' von letzter Zelle bis Zeile 2 , evtl anpassen
    If kunden.Cells(i, 1) = kdnr Then
    
        rechnung.Cells(x, y) = kunden.Cells(i, 1)
        rechnung.Cells(x, y + 1) = kunden.Cells(i, 2)
        rechnung.Cells(x, y + 2) = kunden.Cells(i, 3)
        kunden.Rows(i).Delete
        x = x + 1
    End If
    
Next
End Sub

gruß

andi


Bild


Betrifft: AW: Nach Kriterium markieren
von: RalfH
Geschrieben am: 05.11.2003 21:42:41

Hallo Andi,

erst mal besten Dank für Deine Mühe. Aber ich habe auch mal weiter gebastelt, evtl. ist das ganze nicht besonders geschickt und elegant - aber es funktioniert.

Ich füge mal den Code bei:

Application.ScreenUpdating = False
'HdlNr kopieren
Range("A6").Copy
Range("A2").Select
ActiveSheet.Paste
'
'nach HdlNr selektieren
Range("A7").Select
Range("A5:C366").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
"A1:A2"), CopyToRange:=Range("E5:G5"), Unique:=False
'HdlNr in Lieferschein
Range("A2").Copy
Windows("LIEFERSCHEIN.XLS").Activate
Sheets("Lieferschein").Select
Range("I11").Select
Selection.PasteSpecial Paste:=xlValues
'Positionen in Lieferschein
Windows("RUECKSTAENDE.XLS").Activate
Sheets("Liefer").Select
Range("F6:G30").Copy
Windows("LIEFERSCHEIN.XLS").Activate
Sheets("Lieferschein").Select
Range("C20").Select
Selection.PasteSpecial Paste:=xlValues
'
'Lieferschein drucken
'call M_Auftrag_manuell
'
'verarbeitete Position löschen
Windows("RUECKSTAENDE.XLS").Activate
Sheets("Liefer").Select
Dim i%
Range("a:g").Select
For i = 86 To 6 Step -1
If Cells(i, 5) <> "" Then
Rows(i).EntireRow.Select
Selection.EntireRow.Delete
End If
Next i
Application.ScreenUpdating = True

Nochmal Danke

Gruss Ralf


Bild


Betrifft: AW: Nach Kriterium markieren
von: Andi_H
Geschrieben am: 05.11.2003 22:26:47

Hi Ralf,

die selects kannst du weglassen, die machen den code nur unübersichtlich und bringen nichts

ohne select:

sheets("Lieferschein").Range("I11").PasteSpecial Paste:=xlValues

dim i%
For i = 86 To 6 Step -1
If Sheets("Liefer").Cells(i, 5) <> "" Then Sheets("Liefer").Rows(i).Delete
Next i


mit select:
Sheets("Lieferschein").Select
Range("I11").Select
Selection.PasteSpecial Paste:=xlValues


Sheets("Liefer").Select
Dim i%
Range("a:g").Select
For i = 86 To 6 Step -1
If Cells(i, 5) <> "" Then
Rows(i).EntireRow.Select
Selection.EntireRow.Delete
End If
Next i

grüße


Bild


Betrifft: AW: Nach Kriterium markieren
von: RalfH
Geschrieben am: 05.11.2003 22:29:43

Hallo Andi,

das probier ich gleich mal.

Besten Dank

Gruss
Ralf


Bild

Beiträge aus den Excel-Beispielen zum Thema " Nach Kriterium markieren"