- Megújult mobilos felület, fórumos ráncfelvarrás a PROHARDVER! lapcsaládon
- Eladhatatlannak ítélt CPU-k eladásával javult az Intel node-ok kihozatala
- Az AI átformálja a Peugeot modelljeit is
- Ráműthető a Linux PlayStation 5-re, de csak egy boot erejéig
- Mindenféle környezeti behatásnak ellenállnak az ASUS új TUF tápjai
- NVIDIA GeForce RTX 5080 / 5090 (GB203 / 202)
- AMD K6-III, és minden ami RETRO - Oldschool tuning
- Azonnali informatikai kérdések órája
- Kompakt vízhűtés
- 3D nyomtatás
- Bluetooth hangszórók
- iPad topik
- Kormányok / autós szimulátorok topikja
- Shield TV-t csinált a Shieldből az NVIDIA
- Vezeték nélküli fülhallgatók
-
PROHARDVER!
PROHARDVER!
Új hozzászólás Aktív témák
-
lokos19
csendes tag
Sziasztok!
kellene egy kis segítség Excelhez, meg kellene írni a programot úgy, hogy ne csak 6-os színre sárgára nézze a cellákat hanem 5 kék színre is és azt egy másik cellában összegezze. mondjuk a Cells(5, 12)
Sub szines()
Dim ter As String
Dim cell As Object
Dim össz As Variant
ter = "A14:V60"For Each cell In Range(ter)
If cell.Interior.ColorIndex = 6 Then össz = össz + cell.Value
Next
Cells(5, 5) = összEnd Sub
THX!
-
Hoorus
őstag
Sziasztok!
Adott egy több ezer soros táblázat, mely egyik oszlopából azokat a sorokat kellene leszűrni, amelyek ismétlődnek. Pontosabban, csak azok a sorok maradjanak a táblázatban, amelyek többször elő fordulnak, az egyedi sorokat szeretném törölni belőle..
Van erre valamilyen megoldás?
Köszönöm
-
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 -
Ha jól értem transzponálni szeretnél?
Pl.:
Élelmiszer_____________Élelmiszer
Édesség______________Édesség
Belvita jóreggelt________Orbit eper
Nettó ár______________Nettó árVagy
Élelmiszer______Édesség_____Belvita_____Nettó ár
Élelmiszer______Édesség_____Orbit_______Nettó ár(Az alsóvonások csak az olvashatóság miatt vannak
)Ha minden termék 4 adatból áll, akkor szerencsések vagyunk, mert ciklussal gyorsan feldolgozhatóak.
Csak a kérdés, hogy a fentiből melyik kell.Ha a 2., akkor
Sub darabolo()
Dim LastRow As Integer
LastRow = ActiveSheet.UsedRange.Rows.Count
For i = 1 To LastRow Step 5
For j = 0 To 3
'Vegye ki az első négy sort és illessze be pár oszloppal odébb.
Cells(i + j, 1).Select
Selection.Copy
Cells(i, 3 + j).PasteSpecial xlPasteValues
Next
'Az elválasztó sor miatt ugrok 5-öt.
Next
End Sub -
fluxion
őstag
Sziasztok!
Van egy szöveges állományom amelyben termékek vannak felsorolva:
Élelmiszer
Édesség
Belvita jóreggelt 50g mézzel-mogyoróval
Nettó ár: 83 FtÉlelmiszer
Édesség
Orbit Eper 14g.
Nettó ár: 78 FtA termékek csak egyetlen üres sorral vannak elválasztva. Ezt szeretném úgy excelbe importálni, hogy minden termék új sorba kerüljön és a terméktulajdonságok külön oszlopokba.
Van ötletetek?
-
Szia!
"Ez azt jelenti, hogy mindig van a szám után egy betű és a formátum szöveg?"
Basszus, igazad van (ebben is)!
Minden bizonnyal emiatt nem ment a szorzás, mert az eredeti cella szöveg formátumú volt (vagyis általános). Viszont valamiért az adatmásolás továbbra sem megy. Szerintem itt van a probléma, valószínűleg a "fajlnev" (vagy épp a "cellap") miatt:Set cellap = ThisWorkbook.ActiveSheet
...
cellap.Cells(19 + 2 * adat, oszlop) = Left(fajlnev.Sheets("Sheet1").Cells(36 + 2 * (adat - 1), 16), Len(fajlnev.Sheets("Sheet1").Cells(36 + 2 * (adat - 1), 16) - 1))A végén pedig szeretném bezárni a megnyitott file-t, de a Workbooks.Close (fajlnev) paranccsal nem megy, pedig a Workbooks.Open (fajlnev) parancsra megnyitja
. -
bteebi
veterán
Sziasztok!
Van egy file-om egy modulban lévő makróval. A file különböző - de megegyező struktúrájú - lapjaira szeretnék más Excel file-okból adatokat bemásolni. A másolandó adatokon minimális változtatást végeznék: az eredeti adatok általános formátuma pl. "3.2k", ezt - az utolsó karakter levágása után - felszorzom 1000-rel, és azt szeretném bemásolni, a számformátumot "0"-ra állítva.
Összességében egy dialógusablakkal szeretném megnyitni az adatforrásként szolgáló file-t, viszont nem tudom, hogy hogyan kell(ene) meghivatkozni ahhoz, hogy menjen a másolás.
A jelenlegi makró:
Sub kitoltes()
Dim ablak As FileDialog, fajlnev As String, FileChosen As Integer
Set ablak = Application.FileDialog(msoFileDialogOpen)
FileChosen = ablak.Show
ablak.Title = "Válaszd ki az importálandó file-t"
ablak.InitialFileName = ActiveWorkbook.Path
ablak.InitialView = msoFileDialogViewList
ablak.Filters.Clear
ablak.Filters.Add "Excel 2003 worksheet", "*.xls"
ablak.Filters.Add "Excel 2010 worksheet", "*.xlsx"
ablak.Filters.Add "Excel makró", "*.xlsm"
ablak.FilterIndex = 1
If FileChosen = -1 Then
fajlnev = ablak.SelectedItems(1)
Workbooks.Open (fajlnev)
Else: Exit Sub
End If
Dim adat As Integer, oszlop As Integer
For adat = 1 To 10
For oszlop = 2 To 10 Step 4
'ebben a sorban valószínűleg több hiba is van:
ActiveSheet.Cells(19 + 2 * adat, oszlop) = 1000 * (Left(fajlnev.Sheets("Sheet1").Cells(36 + 2 * (adat - 1), 16), Len(fajlnev.Sheets("Sheet1").Cells(36 + 2 * (adat - 1), 16) - 1)))
ActiveSheet.Cells(19 + 2 * adat, oszlop).NumberFormat = "0"
Next oszlop
Next adat
End SubHa benne van az 1000-rel való szorzás, akkor "Type mismatch" hibát dob, ezért jobb híján beszúrtam egy plusz sort, így már legalább az a része működik:
ActiveSheet.Cells(19 + 2 * adat, oszlop) = ActiveSheet.Cells(19 + 2 * adat, oszlop) * 1000Tudnátok segíteni a hibák kijavításában? Előre is köszönöm!
-
így van, önmagában ez egy jó megoldás, de ha ez egy összetettebb feltételrendszer része, akkor már nem igazán használható
pedig a szűrés is ugyanígy működik, azt függvénnyel elég körülményes megoldani
az eredeti kérdésre adott válaszodat mindenesetre még egyszer köszönöm, sokat segítettél vele!
-
Locsi
senior tag
Hogy érthetőbb legyen, amit evvel "Hogy lehetne ennél azt megcsinálni, hogy a két kitöltött oszlopból (D-C) kiszámolja a az eltelt időkülönbséget (2015.03.20 8:55:35 - 2015.03.20 8:54:33) azt beírja a G oszlopba, és ezt elossza az F oszlopban lévő értékkel, az meg beírja a H oszlopba." akarok, megpróbálom egy képpel érthetővé tenni. Amúgy melóhelyen lenne a termelést követő gépnapló, a papírt elkerülendő.
-
Fiktívnek azt nevezném, amit beírsz a kritériumtáblába, de az eredeti táblában nem szerepel. Erre nem tud szűrni az irányított-, vagy speciális szűrő.
Ha az eredeti táblába veszel fel egy új oszlopot, ahol bizonyos számításokat, összehasonlításokat végzel, az egy segédoszlop, része lesz a táblázatodnak, lehet rá szűrni.
Csakis a fiktív elnevezéssel nem értek egyet.
-
kb ugyanezt csináltam, csak az A oszlop mellé darabteli függvénnyel megszámoltam, hogy az adott elem hányszor van benne a tartományban majd a max függvényel a max értéket kikerestem és index/hol.van-nal az értékhez tartozó elemet megkerestem
Csak azt hittem van más megoldás
Ja és köszönöm
-
hhheni
tag
sziasztok!
megint a kritériumtáblával szívok
több más feltétel között szerepel az is, hogy a pasi fizetése (ami a D oszlopban található) az átlagosnál nagyobb legyen
én ezt csak úgy tudom megoldani, hogy beírok egy fiktív, "számolás" nevű mezőt a kritériumtáblába, és alá ezt a képletet: =D2>ÁTLAG($D$2:$D$190), és így működik is
nem tudja valaki ezt a feltételt közvetlenül a D (fizetés) oszlopra megfogalmazni, hogy ne kelljen új mezőt bevezetnem?
köszi minden ötletet!
heni -
Akkor egy segédmunkalapon felírnám a munkalapokat egymás alá. X-et tetetnék, amibe kell másolni. Majd szűrő az X-re, a megmaradt neveket tömbbe gyűjteném majd ciklussal a megfelelő munkalapokra másolnám. Ne bonyolítsuk, hogy munkalaponként máshová
Szűréshez kulcssszó:autofilter
...Szanaszét kommentelten. Fáradtan ez lett.....valószínűleg a topiktulaj tud majd szebbet is.
Sub Munkalapozó()
Dim MunkalapTomb As Variant
Dim WS As String
Dim lastrow As Integer
'Segéd sheet-en a munkalapok nevei. x-szel kell jelölni, hogy mi kell
Sheets("Segéd").Range("A1:B200").AutoFilter Field:=2, Criteria1:="x"
Range("A2:A" & ActiveSheet.UsedRange.Rows.Count).SpecialCells(xlCellTypeVisible).Select
'mennyi munkalapról van szó. Mekkora lesz a tömb
lastrow = ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Rows.Count
'másolás
Selection.Copy
'beillesztés egy segédoszlopba
Range("E1").PasteSpecial xlPasteValues
'tömbbe másolás
MunkalapTomb = Sheets("Segéd").Range("E1:E" & lastrow).Value
'segédoszlop törlése
Range("E1:E" & lastrow).Clear
'ciklus amekkora a tömb mérete
For i = 1 To UBound(MunkalapTomb)
'vegye ki a tömb soron következő elemét
WS = MunkalapTomb(i, 1)
'itt kell megadni, hogy mit akarsz másolni
Sheets("Segéd").Range("A1:A10").Select
'vágólapra tegye ki
Selection.Copy
'a megfelelő munkalapra illessze be az A1-től.
Sheets(WS).Range("A1").PasteSpecial xlPasteValues
Next
'Szűrő kikapcsolása
Sheets("Segéd").AutoFilterMode = False
End Sub
Csak a kérdés, hogy a fentiből melyik kell.
.
Új hozzászólás Aktív témák
Hirdetés
- Windows 10/11 Home/Pro , Office 2024 kulcsok
- Eladó jogtiszta, Windows 11/10, Office 2019/2021/2024, Fizikai és Digitális licencek, Számlával.
- Játékkulcsok olcsón: Steam, Uplay, GoG, EA, Xbox stb.
- HP. Laptop. i5. Model: 15-da1002nq
- PC Szervizeket, Gépépítőket keresek B2B szoftver partnerségre (E-számlával)
- Owl Labs Owl Bar 4K Videokonferencia Rendszer FRS100
- BESZÁMÍTÁS! Gigabyte Aorus Master RTX 3070 8GB videókártya garanciával hibátlan működéssel
- Telefon felvásárlás!! Honor 400 Lite, Honor 400, Honor 400 Pro
- GAMER PC! Intel i9-12900KF / RTX 5070 / 32GB DDR4 /1TB Gen4 / B760 /1350w Platinum! BeszámítOK!
- Honor 90 Lite 256GB, Kártyafüggetlen, 1 Év Garanciával
Állásajánlatok
Cég: Laptopműhely Bt.
Város: Budapest