Macro za "podvajanje" vrstic v odvisnosti od podatka

[igorjup]

Pozdravljeni!

Ker sem dobil odgovor, da moja želja ni rešljiva z enostavno formulo sem se malce poglobil v marcroje, čeprav mi zadeve do sedaj niso bile poznane. Še vedno pa mi na koncu zaradi neznanja zmanjka nekaj korakov do končne rešitve.

Moja želja je, da bi:

V excel tabeli imam vrstice z različnimi podatki. Vrstice so "unikatne". Rad bi jih podvojij, potrojil, početveril, v odvisnosti od enega podatka v tej vrstici. Se pravi vsaka vrstica se mora različno "podvajati"

Primer:
111111 2
222222 1
333333 3
444444 1


Jaz pa bi rad dobil ven:
111111 2
111111 2
222222 1
333333 3
333333 3
333333 3
444444 1

Našel sem en macro, ki vrstice "podvaja" v odvisnosti od konstante (j=), ki se vpiše, vendar jaz bi želel, da je to podatek in ne fiksno določena konstanta.

Sub test()
Dim j As Integer, r As Range, c As Range, r1 As Range, r2 As Range
j = 10
Application.ScreenUpdating = False
Worksheets("sheet3").Cells.Clear
Set r = Range(Range("A2"), Range("A2").End(xlDown))
For Each c In r
Range(c, c.End(xlToRight)).Copy

With Worksheets("sheet3")
Set r1 = .Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
.Range(r1, r1.Offset(j - 1, 0)).PasteSpecial
End With
Next c
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Hvala

Igor

[admin]

Pozdravljeni,

glede na vaše vhodne podatke in podan makro, morate vstaviti samo eno vrstico:

Koda: Izberi vse

    j = c.Range("b1")

Makro pa je potem takšen:

Koda: Izberi vse

Sub test()
  Dim j As Integer, r As Range, c As Range, r1 As Range, r2 As Range
  
  j = 10
  
  Application.ScreenUpdating = False
  Worksheets("sheet3").Cells.Clear
  Set r = Range(Range("A2"), Range("A2").End(xlDown))
  For Each c In r
    Range(c, c.End(xlToRight)).Copy
    
    j = c.Range("b1")
    With Worksheets("sheet3")
      Set r1 = .Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
        .Range(r1, r1.Offset(j - 1, 0)).PasteSpecial
    End With
  Next c

  Application.CutCopyMode = False
  Application.ScreenUpdating = True
End Sub

[igorjup]

Še enkrat hvala Matjaž!

Deluje točno tako kot sem si zamislil.

Lp