Bereich markieren

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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Bereich markieren

29.10.2003 10:49:29

WernerB.

fast perfekt

29.10.2003 11:16:20

geri

AW: fast perfekt

29.10.2003 12:37:14

WernerB.

AW: fast perfekt

29.10.2003 13:36:46

geri

Fehler

29.10.2003 13:55:21

geri

noch eine FRage

29.10.2003 15:13:11

geri

AW: noch eine FRage

29.10.2003 15:48:26

WernerB.

meine Antwort

29.10.2003 17:50:05

geri

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

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

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.

Beliebteste Forumthreads (12 Monate)

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread