Hirdetés
- Vezetékes FEJhallgatók
- Meghozta a régóta várt asztali Ryzen APU-kat az AMD
- Ilyen olcsó sem volt még egy Apple notebook
- Hogy is néznek ki a gépeink?
- TCL LCD és LED TV-k
- Milyen billentyűzetet vegyek?
- Az eddigi legolcsóbb, 3D V-Cache-t használó CPU-ját hozta forgalomba az AMD
- Mégis meglepi egy új GeForce-szal a rajongókat az NVIDIA?
- AMD GPU-k jövője - amit tudni vélünk
- Kormányok / autós szimulátorok topikja
-
PROHARDVER!
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
-
Delila_1
veterán
válasz
slashing
#23720
üzenetére
Nem teljesen olyan, mint a képen, de hasonlít.
Ha kevesebb dolgom lesz, megpróbálom azt a formát kihozni.Sub Oszlopok()
Dim WS1 As Worksheet, WS2 As Worksheet, sor As Long, usor As Long
Dim oszlop As Integer, uoszlop As Integer, cim As String, oszlophova As Integer
Dim WF As WorksheetFunction, sorhova As Long
Set WS1 = Sheets("Munka1")
Set WS2 = Sheets("Munka2")
Set WF = Application.WorksheetFunction
sor = 1
WS1.Select
Do While Cells(sor, 1) <> ""
uoszlop = WS1.Range("A" & sor).End(xlToRight).Column
For oszlop = 1 To uoszlop
cim = Cells(sor, oszlop)
On Error GoTo Tovabb
oszlophova = WF.Match(cim, WS2.Rows(1), 0)
Cells(sor + 1, oszlop).Select
usor = Selection.End(xlDown).Row
sorhova = WS2.Cells(Rows.Count, oszlophova).End(xlUp).Row + 1
Range(Cells(sor + 1, oszlop), Cells(usor, oszlop)).Copy WS2.Cells(sorhova, oszlophova)
Tovabb:
On Error GoTo 0
Next
sor = Range("A" & sor).End(xlDown).Row
sor = Range("A" & sor).End(xlDown).Row
Loop
End Sub -
Fferi50
Topikgazda
válasz
slashing
#23720
üzenetére
Szia!
Most ellenőriztem, sajnos a speciális szűrés nem megy, mert ha nincs olyan fejléc a szűrendő mezőben, akkor hibát dob (bár nem egészen értem a logikáját, hogy miért, de ez van, ezt kell elfogadni.)
Másik ötlet:
Képlet szinten: Hol.van függvénnyel meghatároznám, hogy az adott fejléc hanyadik oszlopban van a másik táblában és abba az oszlopba kell tenni az adatot. (Nyilván ezt le lehet makróval rendezni (match függvény)).
Tehát: kb.így nézne ki
set mlap1=workbooks("Munkafüzet3").sheets("Munka1")
set mlap2=workbooks("Munkafüzet4").sheets("Munka1")
itt kezdheted az oszlopok ciklusát
oszlop=application.match(mlap1.range("A1").value;mlap2.rows('"1:1"),0)
if not iserror(oszlop) then ' ez csak azért kell, ha mégsem lenne olyan fejléc a másik munkalapon
yy=mlap.cells(40000,oszlop).end(xlup).row+1
for xx=2 to mlap1.range("A2").end(xldown).row
mlap2.cells(yy,oszlop).value=mlap1.cells(yy,"A").value
yy=yy+1
next
else
msgbox "Nincs ilyen fejléc: " & mlap1.range("A1").value
endif
next oszlopokA makró csak szemléltető, nem feltétlenül hibátlan.
Ezt végigcsinálod minden oszlopon, és minden kis táblán.
Ha deklarálod a változókat, az oszlop mindenképpen variant legyen, mert annak értéke hiba is lehet, mint látod.Remélem érthető és tudod használni.
Üdv.
-
slashing
senior tag
válasz
slashing
#23720
üzenetére
Amúgy én úgy képzelem/képzeltem el hogy először megkerestetem a célfájl azon sorát amiben a legtovább van adat ezt eltározom egy változóban sorazonosítóként aztán van egy ciklusom ami végigfut az első tábla fejlécsorán mégpedig úgy hogy csinál egy keresést a másik fájl fejlécében és ahol megtalálja az egyezőt ott eltározom az oszlop azonosítót ha ez meg van akkor van egy sor és oszlopazonosítom ahova bemásolhatja az adatokat. Arra mondjuk figyelni kell hogy a sorazonosító ne legyen ciklusban nehogy lépcsős legyen az egész. Így leírva milyen egyszerű
Új hozzászólás Aktív témák
- RETRO beárazás (mobil, PC, konzol)
- One mobilszolgáltatások
- Mozgásban a Forza Horizon 6
- Vezetékes FEJhallgatók
- Milyen okostelefont vegyek?
- Meghozta a régóta várt asztali Ryzen APU-kat az AMD
- Autós topik
- Audi, Cupra, Seat, Skoda, Volkswagen topik
- Ilyen olcsó sem volt még egy Apple notebook
- Hogy is néznek ki a gépeink?
- További aktív témák...
- Windows 10/11 Home/Pro , Office 2024 kulcsok
- Játékkulcsok olcsón: Steam, Uplay, GoG, Origin, Xbox, PS stb.
- Eredeti Microsoft termékek - MEGA Akciók! Windows, Office Pro Plus, Project Pro, Visio Pro stb.
- Windows 10 11 Pro Office 19 21 Pro Plus Retail kulcs 1 PC Mac AKCIÓ! Automatikus 0-24
- Game Pass Ultimate előfizetések 1 - 36 hónapig azonnali kézbesítéssel a LEGOLCSÓBBAN! AKCIÓ!
- GYÖNYÖRŰ iPhone 12 128GB Black -1 ÉV GARANCIA - Kártyafüggetlen, MS4567
- ÚJ BONTATLAN Apple Macbook Air 15,3 M4 10C CPU/10C GPU/16GB/256GB - Égkék - HUN - mc7a4mg/a 3 év gar
- Apple iPhone 13 Pro Max 512GB,Átlagos,Dobozaval,12 hónap garanciával
- Részletfizetés. BankMentes. Kamatmentes. Új noblechairs EPIC műbőr FEKETE - KÉK 3 év garancia!
- BESZÁMÍTÁS! 4TB Seagate Skyhawk ST4000 SATA HDD meghajtó garanciával hibátlan működéssel
Állásajánlatok
Cég: Laptopműhely Bt.
Város: Budapest
Ha kevesebb dolgom lesz, megpróbálom azt a formát kihozni.
Fferi50
