Új hozzászólás Aktív témák

• #17018 Excelbarat tag sarvari #17013

  Új Válasz 2013-03-01 22:14:28 #17018

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Excelbarat

  tag

  válasz sarvari #17013 üzenetére

  Hi!
  Igazából nagyon nem akartam elbonyolítani így a makró a vastagság és szélesség oszlopokat tölti fel a súly értéket pedig függvénnyel már meg lehet oldani.
  1. lépés Beírod ugyan arra a munkalapra a fejléceket pl A11: Név, B11: Szám, C11:Vastagság, D11: szélesség
  2. makrót elindítod. Működése: a vastagság értékeket beírja annyiszor egymás alá ahány szélesség van. (megkeresi adott esetben C oszlop legalsó értékét és az alá tölti, ezért kell C,D11-be pl beírni a fejlécet, mert az a mérvadó). Majd a szélesség értékeket transzponálja D oszlopba egymás alá addig amíg C oszlopban van érték.
  3. a Súly oszlopba beírod ezt a képletet és végigmásolod (katt a jobb alsó sarkában lévő kis fekete pöttyre 2x)
  =INDEX($A$5:$D$8;HOL.VAN(C12;$A$5:$A$8);HOL.VAN(D12;$A$5:$D$5)) a te példád szerint vannak a hivatkozások! a dollár jelekre figyelj!
  4. makrót törölheted így nem kell makróbarát fájlként elmentened.

  Futtatás előtt egy másolati példányon teszteld mert makró általi módosításokat nem lehet visszavonni!
  Íme a makró:
  Sub tolt()
  Dim darab
  Dim kezd
  Dim ertek
  darab = 3 - 1
  '3-at módosítsd, hogy hány db szélesség érték van(a példádban 10,20,30 tehát 3)!
  For i = 6 To 8
  'Vastagság kezdő(6) és végső(8) értékének sorszámait módosítsd!
  ertek = Cells(i, "A").Value 'A oszlop i sorait írja be megadott számszor az új táblába
  kezd = ActiveSheet.Cells(Rows.Count, "C").End(xlUp).Row + 1
  Range(Cells(kezd, "C"), Cells(kezd + darab, "C")).Value = ertek
  Next i
  'vastagság oszlop feltöltve
  Range(Cells(5, "B"), Cells(5, "D")).Copy 'módosítsd a szélesség adatok kezdő és végső oszlopát
  kezd = ActiveSheet.Cells(Rows.Count, "D").End(xlUp).Row + 1
  Do While Cells(kezd, "C").Value <> ""
  Cells(kezd, "D").Select
  Selection.PasteSpecial Paste:=xlPasteValues, Transpose:=True
  kezd = ActiveSheet.Cells(Rows.Count, "D").End(xlUp).Row + 1
  Loop
  Application.CutCopyMode = False
  'feltöltve a szélesség oszlop
  End Sub
  Alkalmazása: jobb gomb a lapfülre kód megjelenítése oda bemásolod és F5-tel elindítod (vagy felül a zöld play ikonra katt)
  A név és a szám értékeket pedig = jellel végigmásolod.

Új hozzászólás Aktív témák