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

• #5036 wjani tag core1113 #5035

  Új Válasz 2009-06-10 10:38:59 #5036

  Ú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

  

  wjani

  tag

  válasz core1113 #5035 üzenetére

  Szia itt a kód:

  Sub átemelés()
  '
  ' átemelés Makró
  '
  
  '=========================================================================================
  'Ez a makró egy adott oldal első oszlopának adatait emeli át egy mások munkalapra úgy, hogy
  'az első oszlop eslő értéke az első oszlopba, az első oszlop második sorának értéke a
  'a második oszlopba, az első oszlop harmadik értéke a harmadik oszlopba kerül.
  '
  'A zárójelben Munka1 és Munka2 értékeket cseréld le a te munkalapjaid nevére, de pontosan
  'Készítette: Weisz János, wjani@freemail.hu
  '=========================================================================================
  
  'Első és második munkafüzet változóinak felvétele,
  Dim i, j As Variant
  'A sor változók megadása
  Dim s, o, m, n As Integer
  'A sor kezdő értékeinek megadása
  s = 1
  o = 1
  m = 1
  n = 1
  ' Egy ciklus ami addig megy, amíg az első munkalapon az első üres sort nem talál
  Do
  ' Az első érték felvétele a változóba
  i = Worksheets("Munka1").Cells(s, o).Value
  ' Ez a ciklus második oldalon fogja az adatokat átadni
  Do
  'Az első érték felvétele a változóba
  j = Worksheets("Munka2").Cells(m, n).Value
  'Ha az első cella értéke üres, tegye bele az értékeket a megadott cellákba
  If j = Empty Then
  'első cella értéke legyen egyenlő az első cella értékével
  Worksheets("Munka2").Cells(m, n).Value = Worksheets("Munka1").Cells(s, o).Value
  'második cella értéke legyen egyenlő a második sor első cellájának értékével
  Worksheets("Munka2").Cells(m, n + 1).Value = Worksheets("Munka1").Cells(s + 1, o).Value
  'harmadik cella értéke legyen egyenlő a harmadik sor első cewllájának értékével.
  Worksheets("Munka2").Cells(m, n + 2).Value = Worksheets("Munka1").Cells(s + 2, o).Value
  'lépjen ki a ciklusból
  Exit Do
  'Ha a cella értéke nem üres
  Else
  'A második lap első oszlopában ugorjon a következő sorba
  m = m + 1
  'Feltétel vége
  End If
  ' Addig fusson a ciklus, amíg a második lap első oszlopának a sorában üres nem lesz a cella
  Loop Until j = Empty
  'Első munkalap első oszlopában ugorjon 3 cellával lejebb
  s = s + 3
  Loop Until i = Empty
  'Üzenet ha a feladatot végrehajtotta
  MsgBox "Az adatok átemelése megtörtént", vbInformation, "Üzenet a feladat végrehajtásáról!"
  End Sub

  Ez tedd bele abba a makróba, amit létrehozól.
  A makró elején leírtam, hogy mit csinál, minden részre odaírtam a magyarázót.
  Ha valamit nem megy, vagy nem érted jelezz.
  Üdv

  Wjani

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