Bereich markieren

• Bereich markieren von geri vom 29.10.2003 08:57:10
  • AW: Bereich markieren - von WernerB. am 29.10.2003 10:49:29
    • fast perfekt - von geri am 29.10.2003 11:16:20
      • AW: fast perfekt - von WernerB. am 29.10.2003 12:37:14
        • AW: fast perfekt - von geri am 29.10.2003 13:36:46
          • Fehler - von geri am 29.10.2003 13:55:21
            • noch eine FRage - von geri am 29.10.2003 15:13:11
              • AW: noch eine FRage - von WernerB. am 29.10.2003 15:48:26
                • meine Antwort - von geri am 29.10.2003 17:50:05

Betrifft: Bereich markieren
von: geri
Geschrieben am: 29.10.2003 08:57:10
Hallo Excelianer

habe Tabelle mit Werten

in Zelle A1 steht Absender: und in Zelle zb A9 steht auch Absender
Macro sollte wenn dann Bereich von A1 bis A9 selektieren minus eine
Zeile,damit ich Bereich ausschneiden kann
Makro jetzt hat noch Fehler denn Bereich_start und bereich_ende haben
nach Durchlauf selbe Adresse !!! sehe Fehler nicht

Sub Bereich_Markieren()
Dim x, y As Integer
Dim wert, bereich_start, bereich_end
Dim bereich
For x = 1 To 12     '10 Zeilen
For y = 1 To 1  ' 5 Spalten
wert = Cells(x, y)
If wert = "Absender:" Then bereich_start = Cells(x, y).Address
If wert = "Absender:" Then bereich_ende = Cells(x, y).Address
Next
Next
bereich = bereich_start & ":" & bereich_ende
Range(bereich).Select
End Sub

Danke für Hilfe

gruss geri

Betrifft: AW: Bereich markieren
von: WernerB.
Geschrieben am: 29.10.2003 10:49:29
Hallo Geri,

unter Bezug auf Deine Anfrage von gestern habe ich diesen Lösungsvorschlag für Dich:

Option Explicit

Sub Geri()
Dim c As Range
Dim laR As Long, aR As Long, eR As Long, i As Long
Dim BlaNa As String
Application.ScreenUpdating = False
BlaNa = ActiveSheet.Name
aR = 1
For i = 1 To 2200
laR = Sheets(BlaNa).Cells(Rows.Count, 1).End(xlUp).Row
eR = 0
For Each c In Sheets(BlaNa).Range("A" & aR + 1 & ":A" & laR)
If c.Text = "Absender:" Then
eR = c.Row - 1
Exit For
End If
Next c
If eR = 0 Then eR = laR + 3
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(BlaNa).Range("A" & aR & ":G" & eR).Cut
ActiveSheet.Paste
If eR > laR Then Exit For
aR = eR + 1
Next i
Application.ScreenUpdating = True
End Sub

Viel Erfolg wünscht
WernerB.

P.S.: Das Forum lebt auch von den Rückmeldungen der Fragesteller an die Antworter (siehe Forums-FAQ).

Betrifft: fast perfekt
von: geri
Geschrieben am: 29.10.2003 11:16:20
Hallo Werner

Übertrag, Blätter alles Super einziges Manko
die Spalt/Zeilformate sind weg

wenn das noch gehen würde ???

gruss geri

PS.: Sinn und Zweck ist es aus Shop die Bestellungen nach Excel zu
übernehmen, Blattname muss ich dann noch anpassen mit Name aus Zellen wo Name
+ Bestelldatum ergibt dann Blatt Name
Du hast mir aber bereits sehr geholfen

Betrifft: AW: fast perfekt
von: WernerB.
Geschrieben am: 29.10.2003 12:37:14
Hallo Geri,

wie gefällt Dir das:

Option Explicit

Sub Geri()
Dim c As Range
Dim laR As Long, aR As Long, eR As Long, i As Long, j As Long, k As Long
Dim BlaNa As String
Application.ScreenUpdating = False
BlaNa = ActiveSheet.Name
aR = 1
For i = 1 To 2200
laR = Sheets(BlaNa).Cells(Rows.Count, 1).End(xlUp).Row
eR = 0
For Each c In Sheets(BlaNa).Range("A" & aR + 1 & ":A" & laR)
If c.Text = "Absender:" Then
eR = c.Row - 1
Exit For
End If
Next c
If eR = 0 Then eR = laR + 3
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(BlaNa).Range("A" & aR & ":G" & eR).Cut
ActiveSheet.Paste
For j = 1 To 7
Columns(j).ColumnWidth = Sheets(BlaNa).Columns(j).ColumnWidth
Next j
j = aR - 1
For k = 1 To (eR - aR + 1)
j = j + 1
Rows(k).RowHeight = Sheets(BlaNa).Rows(j).RowHeight
Next k
ActiveSheet.Name = Range("B5").Text & " " & Left(Range("B3").Text, 10)
If eR > laR Then Exit For
aR = eR + 1
Next i
Application.ScreenUpdating = True
End Sub

Gruß WernerB.

Betrifft: AW: fast perfekt
von: geri
Geschrieben am: 29.10.2003 13:36:46
Hallo Werner

es klappt perfekt, muss noch etwas ändern, dass schaffe ich
denke selbst, das Problem ist wenn im Name ein Bindestrich Müller-Mohr
kommt dann bleibt Makro stehen wegen NAmensvergabe im Sheet

DANKE für perfekt Work

gruss geri

Betrifft: Fehler
von: geri
Geschrieben am: 29.10.2003 13:55:21
Werner

hab nochmals kontrolliert es ist nicht der - sonder > 31 zeichen
bei Blattname aber dafinde ich Weg

DANKE

gruss geri

Betrifft: noch eine FRage
von: geri
Geschrieben am: 29.10.2003 15:13:11
Hallo Werner

hast du vielleicht noch eine Idee, die Zeile mit Art-Nr.: ist nicht
immer am selben Platz (bedingt durch oben ausgefüllte Zellen)
siehst du Möglichkeit mit VBA

in Spalte A kommt Wert Art-Nr vor --> Select und dann Zeilen einfügen
bis der Wert Art-Nr in Zeile Zb. A30 steht muss durch Zeilen
einfügen aufgefüllt werden da unterhalb die bestelllten Artikel sind,
dann denke ich habe ich alle wichtigen Angaben am selben Ort

DANKE

gruss geri

Betrifft: AW: noch eine FRage
von: WernerB.
Geschrieben am: 29.10.2003 15:48:26
Hallo Geri,

ist das so i.O.?

Sub Geri()
Dim c As Range
Dim laR As Long, laR2 As Long, aR As Long, eR As Long, i As Long, j As Long, k As Long
Dim Lz As Integer
Dim BlaNa As String
Application.ScreenUpdating = False
BlaNa = ActiveSheet.Name
aR = 1
For i = 1 To 2200
laR = Sheets(BlaNa).Cells(Rows.Count, 1).End(xlUp).Row
eR = 0
For Each c In Sheets(BlaNa).Range("A" & aR + 1 & ":A" & laR)
If c.Text = "Absender:" Then
eR = c.Row - 1
Exit For
End If
Next c
If eR = 0 Then eR = laR + 3
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(BlaNa).Range("A" & aR & ":G" & eR).Cut
ActiveSheet.Paste
For j = 1 To 7
Columns(j).ColumnWidth = Sheets(BlaNa).Columns(j).ColumnWidth
Next j
j = aR - 1
For k = 1 To (eR - aR + 1)
j = j + 1
Rows(k).RowHeight = Sheets(BlaNa).Rows(j).RowHeight
Next k
laR2 = Cells(Rows.Count, 1).End(xlUp).Row
For Each c In Range("A1:A" & laR2)
If c.Text = "Art-Nr." Then
Lz = 30 - c.Row
If Lz > 0 Then
Rows(c.Row & ":" & c.Row + Lz - 1).Insert Shift:=xlDown
Exit For
End If
End If
Next c
ActiveSheet.Name = Range("B5").Text & " " & Left(Range("B3").Text, 10)
If eR > laR Then Exit For
aR = eR + 1
Next i
Application.ScreenUpdating = True
End Sub

Gruß WernerB.

Betrifft: meine Antwort
von: geri
Geschrieben am: 29.10.2003 17:50:05
Hallo Werner

na einfach gesagt PERFEKT hat mich ein schönes Stück
weitergebracht, nun muss ich mir weitere Konzept überlegen
wegen Rechnung, Lieferschein usw.

Zur Info der Webshop ist von Databecker (noch nicht im Handel)
aber Demo verfügbar

Recht herzlichen Dank für Deine Mühe

gruss aus Schaffhausen

geri

Excel-Beispiele zum Thema " Bereich markieren"
Leerzeichen aus einem Bereich löschen	Befindet sich die aktive Zelle in einem bestimmten Bereich?
Mehrbereichsauswahl auf eine Seite drucken.	Spalten einer Mehrbereichsauswahl ausblenden.
Bereich mit Maximalwert markieren	Benannten Bereich erweitern
Bereich in RefEdit-Element eingeben und auslesen	Benutzerdefinierte SVERWEIS-Funktion über mehrere Bereiche
Letzter Wert aus einem Bereich	Bereiche bei Mehrfachauswahl prüfen