Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
768to772
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
768to772
768to772
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Zeile kopieren falls bestimmte Zelle >0

Zeile kopieren falls bestimmte Zelle >0
09.06.2006 22:28:47
Alex
Hallo Forum,
hab eine Frage und hoffe Ihr könnt mir helfen.
In Spalte A stehen Artikelnummern die selbe Artikelnummer kann in der Spalte A auch mehmals stehen.
In Spalte B steht die Anzahl der Artikelnummern (1-100).
Hier ein Beispiel:
A / B
12AAA / 3
12AAA / 1
16BBB / 1
16BBB / 1
16BBB / 1
Ist nun der Wert einer Zelle in der Spalte B grösser als 1 so soll unter der jeweiligen Zeile diese Zelle Kopiert werden und zwar so oft wie der Anzahl in spalte B. (in einem neuen worksheet)
Stelle mir das so vor:
A / B
12AAA / 1
12AAA / 1
12AAA / 1
12AAA / 1
16BBB / 1
16BBB / 1
16BBB / 1
Es wäre schön wenn mir jemand helfen könnte.
Danke
Gruß
Alex

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Zeile kopieren falls bestimmte Zelle >0
09.06.2006 23:32:23
Josef
Hallo Alex!
Ich nehme an, daß die Daten ab Zeile 2 stehen.
Sub kopiereZeilen()
Dim objSh As Worksheet
Dim varA As Variant, varB As Variant, varC() As Variant
Dim lngRow As Long, lngLast As Long, lngIndex As Long
Dim intC As Integer


lngLast = Cells(Rows.Count, 1).End(xlUp).Row

If lngLast < 2 Then lngLast = 2

varA = Range("A2:A" & lngLast)
varB = Range("B2:B" & lngLast)

Redim varC(1 To Application.Sum(varB), 1 To 2)

On Error Resume Next

If IsArray(varA) Then
  For lngRow = 1 To UBound(varA, 1)
    For intC = 1 To varB(lngRow, 1)
      lngIndex = lngIndex + 1
      varC(lngIndex, 1) = varA(lngRow, 1)
      varC(lngIndex, 2) = 1
    Next
  Next
Else
  For intC = 1 To UBound(varC, 1)
    varC(intC, 1) = varA
    varC(intC, 2) = 1
  Next
End If

On Error GoTo 0

Set objSh = Sheets.Add(after:=ActiveSheet)

With objSh
  .Name = Format(Now, "ddmmyy_hhmmss")
  .Range("A2:B" & UBound(varC, 1) + 1) = varC
End With

Set objSh = Nothing

End Sub


'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Anzeige
AW: Zeile kopieren falls bestimmte Zelle >0
10.06.2006 14:06:38
Alex
Hallo Sepp,
das ist super und funktioniert genau so wie ich es wollte.
DANKE DIR VIELMALS!!!!
Gruß
Alex

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige