- Fejhallgató erősítő és DAC topik
- MILC felhasználók szakmai topikja
- Milyen billentyűzetet vegyek?
- Gaming notebook topik
- Kormányok / autós szimulátorok topikja
- AMD vs. INTEL vs. NVIDIA
- HiFi műszaki szemmel - sztereó hangrendszerek
- Lenovo Legion és IdeaPad Y széria
- AMD Navi Radeon™ RX 9xxx sorozat
- NVIDIA GeForce RTX 5080 / 5090 (GB203 / 202)
-
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
alevan #31785 üzenetére
Van itt 3 makró.
Sub Gyujtes()
Dim lap As Integer, usor As Long
Sheets(1).Range("N:Q") = ""
'Címsor az első lapon az N1:Q1-be
Sheets(1).Range("N1:Q1") = Sheets(1).Range("A1:D1").Value
For lap = 1 To Worksheets.Count 'Lapok tartalma az első lapra
usor = Sheets(1).Range("N" & Rows.Count).End(xlUp).Row + 1
Sheets(lap).Range("A1").CurrentRegion.Offset(1).Copy Sheets(1).Range("N" & usor)
Next
Rendez
End SubSub Rendez()
Dim usor As Long
Sheets(1).Select
usor = Range("N" & Rows.Count).End(xlUp).Row
Range("N1").CurrentRegion.Select
ActiveWorkbook.Sheets(1).Sort.SortFields.Clear
ActiveWorkbook.Sheets(1).Sort.SortFields.Add Key:=Range("N2:N" & usor), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets(1).Sort
.SetRange Range("N1:Q" & usor)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Fajlokba usor
End SubSub Fajlokba(usor)
Dim utvonal As String, elso As Long, ucso As Long, nev As String
utvonal = "D:\Mentés\" '*** Ezt írd át! **************
elso = 2: ucso = 2: nev = Sheets(1).Range("N2")
Do
nev = Sheets(1).Cells(elso, "N")
If nev = "" Then Exit Do
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = nev
Range("A1:D1") = Sheets(1).Range("A1:D1").Value 'Címsor az új füzetbe
ucso = Application.Match(nev, Sheets(1).Columns(14), 1)
Sheets(1).Range("N" & elso & ":Q" & ucso).Copy Sheets(nev).Range("A2")
ActiveSheet.Move
ActiveWorkbook.SaveAs Filename:=utvonal & nev & ".xlsx", FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
elso = ucso + 1
Loop
Sheets(1).Select
MsgBox "Kész", vbInformation
End SubA harmadikban írt át a csillagokkal jelzett sorban az útvonalat.
Az első makrót (Gyujtes) kell indítanod, az majd hívja a másik kettőt.
Az első lap N:Q oszlopába összegyűjti a többi lap adatait, rendezi a nevek szerint, majd új lapra másolja egyenként a nevekhez tartozó sorokat. Ezt az új lapot áthelyezi egy új fájlba, és menti a megadott névvel, majd be is zárja. -
DeFranco
nagyúr
válasz
alevan #31779 üzenetére
a legyűjtés nem para, azt megcsinálod egy indirektbe ágyazott fkeressel akár, viszont ha minden sornak egyedi munkalapot kell csinálni, akkor az több ezer sornál egyrészt abnormálisan sok munkalap, másrészt kézzel kivitelezhetetlen.
a példa jó, de a konkrét feladat méretéről tudnál írni valami konkrétabbat?
-
Fferi50
Topikgazda
válasz
alevan #30533 üzenetére
Szia!
Az FKERES függvény lesz a megoldás. Pl
első "adatbázis"
D1 cella képlete: =Fkeres($A1;"Második adatbázis $A$1:$C$20000;2;0)
E1 cella képlete: =Fkeres($A1;"Második adatbázis $A$1:$C$20000;3;0)(Kis gonoszkodás - nem két adatbázisod van, hanem 2 táblád - 2 külön excel fájlban vagy egy fájlban két munkalapon).
Üdv.
-
Fferi50
Topikgazda
válasz
alevan #26181 üzenetére
Szia!
A következő megoldást javaslom:
Sub fajlmasolo()
' A makró legyen a Master fileban, amit makróbarát fájlként kell a művelet elindítása előtt elmenteni!
' Így a Master.xlsm legyen a forrásfájlokkal egy mappában, ez a mappa mindegy, hogy hol van!.
Dim Filename As String, Pathname As String,xx as Double
Activesheet.Usedrange.Clear ' a munkalap tartalmát kitöröljük
'Hol vannak a fájlok
Pathname = ActiveWorkbook.Path
Filename = Dir(Pathname & "*.xlsx") 'Ha régi formátumban vannak, akkor .xls-re írd át.
xx = 1 'ez az első fájl helye - az első oszlop
'Menjen végig minden fájlon
Do While Len(Filename) > 0
'NEM KELL Megnyitni a forrást!!!
Cells(1, xx).Formula = "='[" & Filename & "]Sheet1'!B2" 'Sheet1 helyére azt a munkalapnevet kell írnod, ahol az adatok vannak a forrásfájlban.
Cells(2, xx).Formula = "='[" & Filename & "]Sheet1'!C8"
Cells(3, xx).Formula = "='[" & Filename & "]Sheet1'!B15"
' itt folytatod a kitöltést a fentiek szerint
xx = xx + 1 ' vesszük a következő oszlopba
Filename = Dir() 'a következő fájlt
Loop
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value ' a képleteket átváltjuk értékre
MsgBox "A másolásnak vége!", vbInformation
End SubMakrót az Alt+F11 után "feltűnő" VBA ablakba tudsz másolni. A menüből ki kell választanod az Insert - Module opciót. Ezután tudod a modulba bemásolni.
A forrásfájlokat utána kitörölheted - vagy az újakkal felülírhatod és ismételten lefuttatod a makrót.
Üdv.
-
Louro
őstag
válasz
alevan #26181 üzenetére
Szia,
egy gyors, esti fusimunka, de hátha használható. Ha nem megy a makrózás, akkor bocsi. Feltételezek egy kisebb hozzáértést
Főleg az adatmásolásnál lehet hasznos, bár pici logikával hamar megvan, hogy hogyan lehet A-ból B-be másolgatni.
A lentit direkt úgy csináltam, hogy a forrásokat kimented egy mappába, így az eredetik érintetlenek maradnak. A fájlokat át se kell nevezni. A lényeg, hogy .xlsx legyen a kiterjesztésük. Azokat mind bedolgozza.
SUB fajlfeldolgozo()
'A Master.xlsx legyen az asztalon.
'A forrásfájlokat másold az Asztal/Forrás mappába ;)
'Így nem kell aggódni, ha 1001 forrás van.
Dim Filename, Pathname As String
Dim SourceWorkbook As Workbook
Dim LeadFinalMsgBox As Boolean
'Hol vannak a fájlok
Pathname = ActiveWorkbook.Path & "\Forrás\"
'Ha régi formátumban vannak, akkor .xls-re írd át.
Filename = Dir(Pathname & "*.xlsx")
'Menjen végig minden fájlon
Do While Len(Filename) > 0
'Megnyitni a forrást
Workbooks.Open(Filename)
'Itt jön a másolgatás.
Range("B2").Select
Selection.Copy
Workbooks("Master.xlsx").Worksheets("Sheet1").Range(Cells(ActiveSheet.Usedrange.Rows.Count,1)).PasteSpecial xlPasteValues
Range("C8").Select
Selection.Copy
Workbooks("Master.xlsx").Worksheets("Sheet1").Range(Cells(ActiveSheet.Usedrange.Rows.Count,2)).PasteSpecial xlPasteValues
'itt akár elegánsan ciklussal is meglehetne csinálni.
'Forrásfájl törlése
Kill Pathname & Filename
'Hol vannak a fájlok
Filename = Dir(Pathname & "*.xlsx")
Loop
End SUB
Új hozzászólás Aktív témák
Hirdetés
- One otthoni szolgáltatások (TV, internet, telefon)
- Samsung Galaxy Watch7 - kötelező kör
- Nintendo Switch 2
- Fejhallgató erősítő és DAC topik
- Ezek a OnePlus 12 és 12R európai árai
- sziku69: Fűzzük össze a szavakat :)
- Elektromos autók - motorok
- MILC felhasználók szakmai topikja
- exHWSW - Értünk mindenhez IS
- Milyen okostelefont vegyek?
- További aktív témák...
- Eladó steam/ubisoft/EA/stb. kulcsok Bank/Revolut/Wise (EUR, USD, crypto OK)
- Sea of Thieves Premium Edition és Egyéb Játékkulcsok.
- Eredeti Microsoft termékek - MEGA Akciók! Windows, Office Pro Plus, Project Pro, Visio Pro stb.
- ROBUX ÁRON ALUL - VÁSÁROLJ ROBLOX ROBUXOT MÉG MA, ELKÉPESZTŐ KEDVEZMÉNNYEL (Bármilyen platformra)
- Bitdefender Total Security 3év/3eszköz! - Tökéletes védelem, Most kedvező áron!
- AKCÓÓÓ!!! Panasonic CF-XZ6 AIO all-in-one laptop tablet 2k touch i5-7300u speciális ütésálló
- AKCIÓ! MSI Z690 i7 12700K 32GB DDR4 1TB SSD RX 6800 16GB Phanteks P600S Cooler Master 750W
- ÁRGARANCIA! Épített KomPhone i5 13400F 32/64GB RAM RX 7700 XT 12GB GAMER PC termékbeszámítással
- LG 65QNED87T / 65" - 164 cm QNED / 4K UHD / 120Hz & 3ms / HDR 10 Pro / FreeSync Premium / HDMI 2.1
- BESZÁMÍTÁS! Asus A520 R5 3600 16GB DDR4 500GB SSD RTX 2060 8GB Rampage SHIVA CoolerMaster 700W
Állásajánlatok
Cég: Promenade Publishing House Kft.
Város: Budapest
Cég: PCMENTOR SZERVIZ KFT.
Város: Budapest