Macro za "podvajanje" vrstic v odvisnosti od podatka

Pomoč pri izdelavi makrov
Odgovori
igorjup
Prispevkov: 7
Pridružen: Če Maj 10, 2007 8:55 am

Macro za "podvajanje" vrstic v odvisnosti od podatka

Odgovor Napisal/-a 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
Site Admin
Prispevkov: 3687
Pridružen: Sr Jul 20, 2005 10:06 pm

Re: Macro za "podvajanje" vrstic v odvisnosti od podatka

Odgovor Napisal/-a 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
lp,
Matjaž Prtenjak
Administrator
igorjup
Prispevkov: 7
Pridružen: Če Maj 10, 2007 8:55 am

Re: Macro za "podvajanje" vrstic v odvisnosti od podatka

Odgovor Napisal/-a igorjup »

Še enkrat hvala Matjaž!

Deluje točno tako kot sem si zamislil.

Lp
Odgovori