-
Fototrend
A Microsoft Excel topic célja segítséget kérni és nyújtani Excellel kapcsolatos problémákra.
Kérdés felvetése előtt olvasd el, ha még nem tetted.
Új hozzászólás Aktív témák
-
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 SubEz 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.
ÜdvWjani
CoViA Online könyvkereskedés,
Új hozzászólás Aktív témák
- Eredeti Microsoft termékek - MEGA Akciók! Windows, Office Pro Plus, Project Pro, Visio Pro stb.
- Steam, Windows, Origin kulcsok, előfizetések közvetlenül a kiadótól, a LEGJOBB ÁRON!
- Windows 10/11 Home/Pro , Office OEM/Retail kulcsok
- Adobe Creative Cloud - 2024. 04. 05 - 2025. 04. 05-ig
- Játékkulcsok olcsón: Steam, Uplay, GoG, Origin, Xbox, PS stb.