-
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
-
Pakliman
tag
Egy lehetséges megoldás:
Sub Makró1()
Dim us As Long 'utolsó sor
Dim sor As Long
Dim osz As Long
Dim odb As Long 'figyelendő oszlopok száma
Dim nüdb As Long 'nem üres cellák a sorban
Dim ü As Long 'hány oszlopra van a következő nem üres cella
Dim t
t = Timer
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'21121 sor
'soronként átlag 1,4 db üres cella
'Proci: Ryzen 5 2600
'16GB RAM
'Futási idő: 9,84 másodperc
us = Columns("L").Rows(Cells.Rows.Count).End(xlUp).Row
odb = Range(Columns("L"), Columns("Q")).Columns.Count
For sor = 1 To us
nüdb = Application.CountIf(Range(Cells(sor, "L"), Cells(sor, "Q")), "<>")
If nüdb < odb Then
For osz = Columns("L").Column + 1 To Columns("Q").Column - 1
If IsEmpty(Cells(sor, osz)) Then
If Application.CountIf(Range(Cells(sor, osz + 1), Cells(sor, "Q")), "<>") > 0 Then
'Ha van egyáltalán még átpakolható adat...
'Ezen vizsgálat nélkül 12,2 másodpercig fut a 9,84 helyett!!
ü = 1
Do While IsEmpty(Cells(sor, osz + ü)) And (osz + ü <= Columns("Q").Column - 1)
ü = ü + 1
Loop
Cells(sor, osz) = Cells(sor, osz + ü)
Cells(sor, osz + ü).ClearContents
Else
Exit For
End If
End If
Next osz
End If
Next sor
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
Debug.Print Round(Timer - t, 2)
End SubA futás ideje nagymértékben függ az üres cellák számától
-
Pakliman
tag
Szia!
Egy lehetőség:
Public Sub xx()
Const sFN As String = "d:\teszt.csv"
Dim csv As Integer
Dim sLine As String
Dim o As Long 'Az adatoszlopok száma...
Dim i As Long
Dim j As Long
Dim db As Long
Dim s As String
Dim arr0, arr
csv = FreeFile()
Open sFN For Input As csv
ReDim arr0(1 To 3, 0 To db)
Do While Not EOF(csv)
Line Input #csv, sLine
arr = Split(sLine, ";")
i = UBound(arr) + 1
If db = 0 Then o = i
If i = 3 Then
'Ha 3 részes a sor...
db = db + 1
ReDim Preserve arr0(1 To o, 0 To db)
s = arr(0)
'Töröljük az elejéről és/vagy a végéről a macskakörmöt
If Left(s, 1) = Chr(34) Then s = Mid(s, 2)
If Right(s, 1) = Chr(34) Then s = Left(s, Len(s) - 1)
arr0(1, db) = s
s = arr(1)
If Left(s, 1) = Chr(34) Then s = Mid(s, 2)
If Right(s, 1) = Chr(34) Then s = Left(s, Len(s) - 1)
arr0(2, db) = s
s = arr(2)
If Left(s, 1) = Chr(34) Then s = Mid(s, 2)
If Right(s, 1) = Chr(34) Then s = Left(s, Len(s) - 1)
arr0(3, db) = s
Else
'...ha nem, akkor az előző végéhez írjuk.
s = sLine
If Left(s, 1) = Chr(34) Then s = Mid(s, 2)
If Right(s, 1) = Chr(34) Then s = Left(s, Len(s) - 1)
arr0(3, db) = arr0(3, db) & vbCrLf & s
End If
Loop
Close #csv
For i = 1 To db
For j = 1 To o
Cells(i, j) = arr0(j, i)
Next j
Next i
End Sub -
Pakliman
tag
válasz
Norbika1493
#42312
üzenetére
Szia!
Ha jól értelmezem a dolgot, akkor az csak VBA-val oldható meg, mert a függvény (MOST()) jövő héten is frissülni fog és az akkori értéket mutatja majd.
Markóval:
A munkalap Change eseményébe kell beírni, hogy ha az adott oszlopban változik egy cella értéke, akkor a meghatározott cellába írja be a dátumot.Private Sub Worksheet_Change(ByVal Target As Range)
'Feltételezzük: Dátum "A" (1.) oszlop, Termék "D" (4.) oszlop
If Target.Column = 4 Then Cells(Target.Row, 1) = Date
End Sub -
Pakliman
tag
válasz
dave0825
#42301
üzenetére
Szia!
Egy lehetőség:
B1:B akármennyicellákba:=DARABTELI($A$2:A2;A2)C1:C akármennyicellákba:=HA(B2=1;SZUMHA($B$2:B2;B2;$B$2:B2);"")D1:D akármennyicellákba:=HAHIBA(INDEX(A:A;HOL.VAN(SOR()-1;C:C;0));"")A C és D segédoszlopokban vannak a szükséges "számító" képletek, a D oszlop tartalmazza az eredményt.
-
Pakliman
tag
válasz
Fferi50
#42294
üzenetére
Céges gépek, egyformák, tulajdonképpen klónok.
A területi beállításokat a pont-pont-vesszőcskéig összehasonlítottam, egyeznek.
Az én gépemen a mai napig működik (évekkel ezelőtt megírt programok, sokan használják), soha nem volt vele gond. Most 3-4 emberke jelezte, hogy már nem úgy műxik, ahogy kellene.
Milyen munkalapfüggvényre gondolsz? -
Pakliman
tag
Sziasztok!
IsDate() mizéria...
Rég óta nyüstölöm az Excelt, találkoztam már pár furcsasággal, de ez szerintem eddig a legrosszabb
Találkozott már valaki hasonlóval?
Mindkettő Windows 10, Office 2016.
A windows régiós és egyéb beállítások valamint az Office verziók megegyeznek (build szám is egyforma), mégis más eredményt kapok a két (valójában több) gépen.
Mindkét képen az Office beépített IsDate függvénye fut!
Kénytelen voltam saját függvényt létrehozni, hogy minden gépen úgy működjön a kód, ahogy kell.
Valakinek esetleg ötlete, hogy mi lehet az ok?
-
Pakliman
tag
válasz
Sprite75
#42240
üzenetére
Szia!
Akkor alakítsd át:
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="\\KHAZASERV\Megosztott\Rendeles Bolt\" & worksheets("valami").cells(vmelyiksor,vmelyikoszlop) & " Rendeles." & Format(Now(), "yyyy.mm.dd. hh-mm") & ".pdf" _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=FalseValamiért már megint nem működnek nálam a BB kódok (félkövér, aláhúzott stb.)
-
Pakliman
tag
Szia!
(Egyféle) megoldás kis kiegészítéssel és makróval:
(Ez a kép már a makró általi lista, a színezés az eredeti)
Minden csoport ki lett egészítve egy új oszloppal, ami azért kell, mert egy tétel többször is szerepelhet és valahogy muszáj megkülönböztetni
P oszlopban:=DARABTELI($O$2:O2;O2)
S oszlopban:=DARABTELI($R$2:R2;R2)
V oszlopban:=DARABTELI($U$2:U2;U2)
FONTOS!!!! Figyelj a dollárjelre!!!!
(Beírod pl. a P2 cellába és "lehúzod" P16-ig)A kód:
Public Sub Rendez()
Dim o As Long
Dim s0 As Long
Dim s As Long
Dim us As Long
Dim us2 As Long
Dim bVan As Boolean
For o = 14 To 20 Step 3
us = Columns(o).Rows(Rows.Count).End(xlUp).Row
For s = 2 To us
If o = 14 Then
'1. oszlopcsoport, csak másolunk...
Cells(s, o - 12) = Cells(s, o)
Cells(s, o - 11) = Cells(s, o + 1)
Cells(s, o - 10) = Cells(s, o + 2)
Else
us2 = Columns(o - 15).Rows(Rows.Count).End(xlUp).Row
For s0 = 2 To us2
bVan = (Cells(s0, o - 15) = Cells(s, o)) And (Cells(s0, o - 14) = Cells(s, o + 1)) And (Cells(s0, o - 13) = Cells(s, o + 2))
If bVan Then Exit For
Next s0
If bVan Then
us2 = s0
Else
us2 = Application.Max(Columns(o - 12).Rows(Rows.Count).End(xlUp).Row, Columns(o - 15).Rows(Rows.Count).End(xlUp).Row) + 1
End If
Cells(us2, o - 12) = Cells(s, o)
Cells(us2, o - 11) = Cells(s, o + 1)
Cells(us2, o - 10) = Cells(s, o + 2)
End If
Next s
Next o
End Sub -
Pakliman
tag
válasz
Jarod1
#42159
üzenetére
1. Biztos, hogy az a cella az aktív, amelytől balra lévő oszlopokat és amely fölött lévő sorokat rögzíteni akarod?
2. Én VBA-ban találkoztam vele.
Ott is KIZÁRÓLAG egy bizonyos, programból létrehozott és kitöltött munkalappal csinálja (Office2016, a létrehozott munkafüzet 4 munkalapot tartalmaz kódból létrehozva!).
A kódot lépésenként végrehajtatva jó értékek vannak a "fagyasztásnál", mégis a P2 cella helyett az I15-öt zárolja.
Ez nem működik:.Cells(2, 16).Select
ActiveWindow.FreezePanes = TrueHelyette ezt használom:
With ActiveWindow
If .FreezePanes Then .FreezePanes = False
.SplitColumn = már_nem_mozgó_oszlop
.SplitRow = már_nem_mozgó_sor
.FreezePanes = True
End With -
Pakliman
tag
válasz
pero19910606
#42157
üzenetére
Public Sub Kitölt()
Dim us As Long
Dim i As Long
Dim sNév As String
'Feltételezzük, hogy az adatok az "Adatok" munkalapon vannak...
With Worksheets("Adatok")
'Megkeressük az utolsó beírandó adat sorát
us = .Cells(.Rows.Count, "A").End(xlUp).Row
'feltételezzük, hogy az adatok a 2. sorban kezdődnek (1. a fejléc)
For i = 2 To us
If True Then 'Ha van valamilyen feltétele a kitöltésnek (pl.: csak a Lekvárzsibbasztó Gépgyár érdekel), akkor a True helyére azt írd be
'kitöltjük a "KÖRLEVELET" a megfelelő adatokkal... pl.:
Worksheets("KÖRLEVÉL").Cells(3, 5) = .Cells(i, 1)
'...stb
'...mentés...(cégnév_azonosító -> megfelelő helyekről összeállítva...)
sNév = "D:\cégnév_azonosító."
'PDF-ként...
Worksheets("KÖRLEVÉL").ExportAsFixedFormat Type:=xlTypePDF, Filename:=sNév & "pdf", OpenAfterPublish:=False
'...majd xlsm-ként...
Worksheets("KÖRLEVÉL").Copy
ActiveWorkbook.SaveAs Filename:=sNév & "xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
ActiveWorkbook.Close
End If
Next i
End With
End Sub -
Pakliman
tag
Egy lehetséges megoldás (csak a totál kezdő Excel felhasználók ellen jó
):Egy normál modulban létrehozol egy változót, ez fogja tárolni a mindenkori aktuális munkalapot:
Public ASH As WorksheetA Thisworkbook modulban ez (illetve hasonló) legyen:
Private Sub Workbook_Open()
'A munkafüzet megnyitásakor elmentjük az éppen aktuális munkalapot:
Set ASH = ActiveSheet
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
'Munkalap aktiválásakor mengnézzük, hogy az új munkalap a védendő-e:
If Sh Is Worksheets("Munka2") Then
'Ha a védendő, akkor jelszót kérünk:
If InputBox("Jelszó:") = "jelszo" Then
'Ha jó a jelszó, engedjük az aktívvá tételt,
'és elmentjük új aktívként
Set ASH = ActiveSheet
Else
'Ha rossz, akkor:
MsgBox "Ehhez a laphoz Neked semmi közöd!!"
'Visszaállítjuk az előző munkalapot aktívnak:
ASH.Activate
End If
End If
End Sub -
Pakliman
tag
-
Pakliman
tag
válasz
koncyka
#41362
üzenetére
Szia!
A "legegyszerűbb" megoldás az lenne, ha a Billingo észrevenné/értesülne az anomáliáról és javítaná a programját. Ha jelzed nekik, talán megoldják. Majd. Egyszer. Valamikor.
Egyéb lehetőség:
(Lásd Összefoglaló!) Worksheet_Change eseménykezelőbe programból megoldod, hogy ha egy cella értéke változik (feltételezzük. hogy az automatikus újraszámítás engedélyezve van!), akkor egy másik munkalap azonos cellájába íródjon be az ÉRTÉK (Workshhets("Importálandó").Cells(Target.Row, Target.Column).Value=Target.Value).
Az importáláshoz már ezt ("Importálandó") a munkalapot kell megadnod.
Ennek a megoldásnak akkor van egy kis (vagy nagy) hátránya, ha sok ezer képlet van a munkalapon, mert nagyon le tudja fogni a gépet
Probléma lehet, ha mindig más táblázattal kell dolgozni
De ha készítesz egy sablont, ami alapján a későbbiekben létrehozod a "munka" munkafüzeteket, akkor csak a sablonba kell EGYSZER megírni a programot -
-
Pakliman
tag
válasz
MCMLXXXII
#41014
üzenetére
Pl: így nyerem ki =szum(munka1!E4
4) az adott hónapot
Akkor most nem igazán értem, hogy mi is lenne a feladat
Nem az adott havi összes érdekel? Mert én ebből is úgy értem: =szum(munka1 dátum 1 től 30 v 31. ÉigHa mégis a havi kell, akkor átalakítva csak a piros sorokat figyelembe véve:
=SZUMHATÖBB(INDIREKT("Munka1!" & HOL.VAN($A2;Munka1!$A:$A;0)+2 & ":" & HOL.VAN($A2;Munka1!$A:$A;0)+2);INDIREKT("Munka1!" & HOL.VAN($A2;Munka1!$A:$A;0)+3 & ":" & HOL.VAN($A2;Munka1!$A:$A;0)+3);">=" & DÁTUM(BAL(B$1;4);KÖZÉP(B$1;5;2);1);INDIREKT("Munka1!" & HOL.VAN($A2;Munka1!$A:$A;0)+3 & ":" & HOL.VAN($A2;Munka1!$A:$A;0)+3);"<=" & DÁTUM(BAL(B$1;4);KÖZÉP(B$1;5;2)+1;0))
"Kínai"-magyar szótár :DD :
HOL.VAN($A2;Munka1!$A:$A;0) megkeresi az "Áru 1" szöveget a Munka1 lapon => 2.sor
DÁTUM(BAL(B$1;4);KÖZÉP(B$1;5;2);1) a 201902-t átalakítja 2019.02.01 dátummá
DÁTUM(BAL(B$1;4);KÖZÉP(B$1;5;2)+1;0) a 201902-t átalakítja 2019.02.30 dátummá (2019.03.01 - 1 nap)
INDIREKT("Munka1!" & ... létrehozza a a másik munkalapra való hivatkozásokat pl.:
INDIREKT("Munka1!" & HOL.VAN($A2;Munka1!$A:$A;0)+2 & ":" & HOL.VAN($A2;Munka1!$A:$A;0)+2) => Munka1!4:4 -
Pakliman
tag
válasz
MCMLXXXII
#41011
üzenetére
Szia!
Egy lehetséges megoldás (ha jól értettem a feladatot):
A képletek (a Munka2 lapon!):
a zöld cellákban:
=SZUMHATÖBB(INDIREKT("Munka1!" & HOL.VAN($A2;Munka1!$A:$A;0) & ":" & HOL.VAN($A2;Munka1!$A:$A;0));INDIREKT("Munka1!" & HOL.VAN($A2;Munka1!$A:$A;0)+1 & ":" & HOL.VAN($A2;Munka1!$A:$A;0)+1);">=" & DÁTUM(BAL(B$1;4);KÖZÉP(B$1;5;2);1);INDIREKT("Munka1!" & HOL.VAN($A2;Munka1!$A:$A;0)+1 & ":" & HOL.VAN($A2;Munka1!$A:$A;0)+1);"<=" & DÁTUM(BAL(B$1;4);KÖZÉP(B$1;5;2)+1;0))a narancs cellákban:
=SZUMHATÖBB(INDIREKT("Munka1!" & HOL.VAN($A2;Munka1!$A:$A;0)+2 & ":" & HOL.VAN($A2;Munka1!$A:$A;0)+2);INDIREKT("Munka1!" & HOL.VAN($A2;Munka1!$A:$A;0)+3 & ":" & HOL.VAN($A2;Munka1!$A:$A;0)+3);">=" & DÁTUM(BAL(B$1;4);KÖZÉP(B$1;5;2);1);INDIREKT("Munka1!" & HOL.VAN($A2;Munka1!$A:$A;0)+3 & ":" & HOL.VAN($A2;Munka1!$A:$A;0)+3);"<=" & DÁTUM(BAL(B$1;4);KÖZÉP(B$1;5;2)+1;0))
A keresendő hónap az első sorban van sima számként pl.: 201904 -
Pakliman
tag
válasz
-szabi-
#40996
üzenetére
Szia!
Egy lehetőség:
(A wiki oldalát jelöld ki CTRL+A-val, majd CTRL+C, aztán a makró indítása)Sub Olvas()
Dim oClip As Object
Dim arr
Dim db As Long
Dim i As Long
Dim sor As Long
Dim bKód As Boolean
'Ez a Microsoft Forms 2.0 Object Library "késői kötése" (c:\windows\system32\FM20.DLL)
Set oClip = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
On Error GoTo Hiba
oClip.GetFromClipboard
'Beolvassuk egy tömbbe a szöveget...
arr = Split(oClip.GetText(1), vbCrLf)
db = UBound(arr)
bKód = False
sor = 0
For i = 0 To db
If arr(i) Like "### ?*" Then
bKód = True
sor = sor + 1
Cells(sor, 1) = Left(arr(i), 3)
Cells(sor, 2) = Mid(arr(i), 5)
End If
If bKód = True Then
If arr(i) Like " ?*" Then
Cells(sor, 3) = Cells(sor, 3) & IIf(Cells(sor, 3) <> "", vbCrLf, "") & Mid(arr(i), 5)
End If
End If
Next i
Hiba:
End Sub -
Pakliman
tag
válasz
Zola007
#40932
üzenetére
[Egy példa...]
Bár ez inkább a VBA része...
[Vagy ez...] -
Pakliman
tag
Szia!
Az utolsó használt cella egy adott oszlopban:
Worksheets("Munkalap_Neve").Cells(Worksheets("Munkalap_Neve").Cells.Rows.Count, oszlop_száma).End(xlUp).Row
(AWorksheets("Munkalap_Neve").elhagyható, ha nem egy konkrét munkalapon, hanem az éppen aktívon akarod futtatni a makrót.)
pl.:Sub x()
Dim us As Long
Dim o As Long
o = 1
us = Cells(Cells.Rows.Count, o).End(xlUp).Row
Cells(us + 1, o) = Application.Sum(Range(Cells(2, o), Cells(us, o)))
End SubKellemes további kísérletezést
-
Pakliman
tag
válasz
JagdPanther
#40873
üzenetére
A 6 helyett:
For row_number = 2 To Worksheets("Lista1").Cells(Worksheets("Lista1").Cells.Rows.Count, 1).End(xlUp).Row -
Pakliman
tag
válasz
JagdPanther
#40870
üzenetére
Szia!
Ennek így működnie kell:
Public Sub SendEmail()
Dim olApp As Object
Dim olMail As Object
Dim row_number As Long
Set olApp = CreateObject("Outlook.Application")
On Error Resume Next
For row_number = 2 To 6
Set olMail = olApp.CreateItem(0)
With olMail
.to = Worksheets("Lista1").Cells(row_number, 1)
.Subject = Worksheets("Lista1").Cells(row_number, 2)
.Body = Worksheets("Lista1").Cells(row_number, 3)
.send
End With
Next row_number
On Error GoTo 0
Set olMail = Nothing
Set olApp = Nothing
End SubJavítottam...
-
Pakliman
tag
Sajnos már 2016-ost használok, nem emlékszem a pontos elérésre
, de kb.:
Keresd meg a beállításokban az Adatvédelmi központot, ott a makróbeállításokat.
Pötty -> Az összes makró engedélyezése...,
Pipa -> A VBA-projekt objektum...
Indítsd újra az Excelt.
A VBA IDE az Alt-F11 lenyomásával indítható. -
Pakliman
tag
Szia!
Neked valami ilyesmi kell:
Public Sub Rendez()
Dim i As Long
With ActiveWorkbook
For i = 1 To 6
'Feltételezzük, hogy a FŐ munkalap neve: FML
.Worksheets("FML").Copy After:=.Worksheets(.Worksheets.Count)
With .Worksheets(.Worksheets.Count)
.Name = "Rend_" & i
.Cells.Sort Key1:=.Columns(i), Header:=xlYes
End With
Next i
End With
End SubTedd be egy mindig elérhető munkafüzetbe (Összefoglaló->personal füzet) és rendelj hozzá egy billentyű kombinációt.
-
Pakliman
tag
válasz
p5quser
#40636
üzenetére
Sajnos várni kell a mesterséges intelligenciára
De addig is - egy kis plusz munkával - "tanítható" adatbázisból is dolgozhatsz.
Létrehozol egy munkafüzetet, amiben 2 oszlopot kell kezelned.
A 1. oszlopban lesznek a különböző felhasználók által használt kifejezések
A 2. oszlopba melléjük írod Te, hogy az mi is akar lenni (vagy Te mit szeretnél látni a zagyvaságok helyett
)
Ezután az FKERES függvénnyel ebben a táblában kikeresed a kapott szöveget és megkapod a kívántat.
Ha hibát ad vissza, akkor egyszerűen csak kibővíted az új jövevénnyel.
Persze, sosem lesz tökéletes, de egyre kevesebb lesz a #HIÁNYZIK eredmény.Kicsit nehezebb feladat rávenni a kuncsaftokat, hogy egységes szövegeket használjanak.
-
Pakliman
tag
válasz
p5quser
#40632
üzenetére
Szia!
A
Dim stdb As Workbook
Dim stnm As Stringsorokat töröld a Workbook_Open metódusból (ha még nem tetted meg), mert különben kizárólag ezek a HELYBEN ÉRVÉNYES változók veszik fel az értékeket (ez miatt hasal el a program is, mert ott nincs értéke az stnm-nek!).
Private Sub Workbook_Open()
stnm = Application.GetOpenFilename
If stnm <> "" Then
Set stdb = Workbooks.Open(stnm)
End If
End SubA
Workbooks(stnm).Sheets(1).Range("A1:B" & Rows.Count).AutoFilter field:=2, Criteria1:="*" & TextBox2.Value & "*"helyett így már használhatod astdb.Sheets(1).Range("A1:B" & Rows.Count).AutoFilter field:=2, Criteria1:="*" & TextBox2.Value & "*"formát! -
Pakliman
tag
válasz
sz_abika
#40578
üzenetére
Szia!
Ha jól értem, hogy mit szeretnél (A D2 cellától a ***-aj jelzett sor előtti sorig szeretnéd feltételesen formázni?)...
Dim jelSora
'Megnézi, hogy a "jel" hanyadik sorban van
jelSora = Application.Match("***", Range("D:D"), 0)
'Ha van egyáltalán "jel", akkor...
If Not IsError(jelSora) Then
With Range("D2:D" & jelSora - 1)
.FormatConditions.Add Type:=xlExpression, Formula1:="=P6<$A$2"
.FormatConditions(.FormatConditions.Count).SetFirstPriority
With .FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = RGB(230, 230, 230)
.TintAndShade = 0
End With
End With
End If -
Pakliman
tag
válasz
RedHarlow
#40558
üzenetére
Szia!
A rövid válasz: igen.
A hosszabb: az Excel meg tudja nyitni táblázatként is
(pl.:Workbooks.OpenXML Filename:="C:\Dokumentumok\adatok.xml", LoadOption:=xlXmlLoadImportToList), ekkor már használható a "DARABTELI" függvény megfelelő változata.
Természetesen egyszerű szövegként is meg lehet nyitni, majd soronként beolvasva a szövegben lehet keresni és számolni a találatokat. -
Pakliman
tag
válasz
Pinocchio23
#40549
üzenetére
Én először ezzel próbálkoznék:
a "ThisWorkbook" modul Workbook_Open metódusban:
1. cellák zárolásának megszüntetése a megfelelő munkalapon,
2. zárolja a meghatározott dátumokat tartalmazó cellákat
3. "Lapvédelem" jelszóvalMost látom, Fferi50 már megelőzött...
-
Pakliman
tag
válasz
mindanee
#40504
üzenetére
Szia!
Ha mutatsz példát a bejövő és a kimeneti struktúrára, akkor tudunk segíteni.
Ha mindig más munkafüzetekkel kell dolgoznod és a kimenetek is folyton újak, akkor az Összefoglalóban lévő "personal" füzetben kell létrehoznod a megfelelő feldolgozó makrót.
Ha a kapott munkafüzetben következetesen vannak a szükséges adatok (mindig ugyanabban az oszlopban, ugyanolyan formában stb.), akkor nincs gond. Ha véges számú változatban kapod (3-4-féle struktúra), akkor még kezelhető a dolog (nekem van 8 különböző embertől 8-féle "adatbázis") -
Pakliman
tag
válasz
RedHarlow
#40505
üzenetére
A legegyszerűbb a feltételes formázás.
Az "A" oszlopra fixen is megcsinálhatod, de ha van rá esély, hogy bárki is hozzányúlhat és elcseszheti, akkor inkább kóddal kell megoldani.
Ezt tedd be a makróba.With Columns(1) 'Az A oszlopra vonatkozóan
.FormatConditions.Delete 'Töröljük az esetlegesen már meglévő formázást
.FormatConditions.Add Type:=xlExpression, Formula1:="=INDIREKT(CÍM(SOR();3))=""X""" 'Létrehozzuk a szükségeset
.FormatConditions(1).Interior.Color = vbGreen 'Beállítjuk hozzá a színt
End WithVagy a
For sor = 1 To sor_uelé,
vagy aNext sorután. -
Pakliman
tag
válasz
RedHarlow
#40501
üzenetére
Igazad van.
Ez kell:Cells(Application.Match("??????_" & Cells(sor, 6) & "_*", Columns(1), 0), 1).Interior.Color = vbGreen
Bár ez csak az első találatot színezi át.
Ha több találat is lehet, akkor egy For .. Next ciklussal kell végignézni az "A" oszlopot.
Vagy feltételes formázás... -
Pakliman
tag
válasz
RedHarlow
#40494
üzenetére
Szia!
Egy kezdetleges lehetőség:
'Az "EREDETI" munkalapra vonatkozik...
Sub fut()
Dim sor_u As Long: sor_u = 13 'Ezt később dinamikusan kell meghatározni, most csak a példa miatt fix.
Dim sor As Long
For sor = 1 To sor_u
'Feltételezem, hogy az A oszlopban a keresendő érték MINDIG aláhúzásjelek között van!!
'Az "F" (6.) oszlopban a "sor" sorban lévő értéket keressük az "A" (1.) oszlopban
If Application.CountIf(Columns(1), "*_" & Cells(sor, 6) & "_*") Then
'Ha találtunk ilyet, akkor a "C" (3.) oszlop "sor" sorába teszünk egy "X"et
Cells(sor, 3) = "X"
End If
Next sor
End Sub -
Pakliman
tag
válasz
p5quser
#40486
üzenetére
A Workbook_Open metódus csakis a munkafüzet megnyitásakor fut le, vagyis az értékadás is akkor történik meg.
Próbáld meg először azt, hogy mentéssel bezárod a munkafüzetet majd újra megnyitod.Ha azt szeretnéd, hogy bármikor rendelkezésre álljanak az új hivatkozások, akkor egy általános modulban kellene létrehozni egy pl. Init nevű eljárást és abba beírni az értékadást.
Később, amikor szükség van az azonosítókra, a kódban egyszerűen csak meghívod az Init eljárást. -
Pakliman
tag
válasz
p5quser
#40480
üzenetére
Szia!
A legegyszerűbb megoldás (szerintem), ha a munkalapokat átnevezed:
Amint láthatod, egy munkalapnak 2 "Neve" van, VBA-ban mindkettő használható, de más módon:
1.: egy tulajdonképpeni "belső" azonosító, közvetlenül lehet hivatkozni rá:Munka3.Range("A1")
2.: ez látszik az Excelben a lapfülön, szövegként hivatkozhatunk rá:Worksheets("Munkaóra").Range("A1")
A 2. változatnál egy általános modulban deklarálni kell a szükséges "változókat"Public ws1 As Worksheet
Public ml3 As Worksheet
Public Össz As Worksheet, majd a Thisworkbook modulban értéket adni neki(k):
pl.:Private Sub Workbook_Open()
Set ws1 = Worksheets("Táblázat")
Set ml3 = Worksheets("Munkaóra")
Set Össz = Worksheets("Segéd")
End Sub -
Pakliman
tag
válasz
dajkapeter
#40466
üzenetére
Szia!
Egy lehetőség:
-
Pakliman
tag
válasz
tgumis
#40459
üzenetére
Szia!
Még egyszerűbben, villogtatás nélkül:
Sub keplet_helyett_ertek()
Dim ws As Worksheet
On Error Resume Next
For Each ws In Worksheets
ws.Cells.SpecialCells(xlCellTypeFormulas, 23).Formula = ws.Cells.SpecialCells(xlCellTypeFormulas, 23).Value
Next ws
On Error GoTo 0
End Sub -
Pakliman
tag
válasz
Hobbbyt
#40456
üzenetére
Ha következetesen használod a "tankolás" szót, akkor tulajdonképpen elég Neked a SZUMHATÖBB függvény.
A táblázatodban a C5 cella lehet pl.:=SZUMHATÖBB(D10:D5000;B10:B5000;"tankolás")
(Az 5000 egy elég nagy tartomány, ami elég lesz egy ideig, de ezeket a címzéseket akár dinamikussá is lehet tenni.)
Elég lehet a SZUMHA is, de a másikkal akár havi/éves stb. szinten is tudsz számoltatni
pl.: 2018-ban ennyit tankoltál (feltételezve, hogy a "Dátum" oszlop dátumot és nem egy formázott számot tartalmaz):=SZUMHATÖBB(D10:D5000;B10:B5000;"tankolás";A10:A5000;">=" & DÁTUM(2018;1;1);A10:A5000;"<=" & DÁTUM(2018;12;31)) -
Pakliman
tag
válasz
EmberXY
#40097
üzenetére
Szia!
Makróval megoldható.
A vázlata a következő (egy lehetséges megoldás):
'végiglépkedsz a táblázatban a neveket tartalmazó cellákon:
'Tegyük fel, hogy a nevek a Névsor munkalap A oszlopában vannakFor sor = 2 To utolsó_név_sora
'a nevet bemásolod a fejlécbe
Range(fejléc_neve_vagy_címe) = Worksheet("Névsor").Cells(sor, 1)
'Kinyomtatod
ActiveSheet.PrintOut
Next sor -
Pakliman
tag
válasz
Tomi_78
#39813
üzenetére
Szia!
Az xlsx (xlsm, xlsb stb.) valójában egy ZIP állomány!
Ez a tömörítvény tartalmaz sok mappát és bennük sok-sok fájlt.
Az "adatok", amiket Te keresel a sheet1.xml-ben (és/vagy a többi sheetx.xml-ben) találhatók.
Persze, ha jelszóval védett a táblázat, akkor gondban leszel...Szerintem keress ingyenesen használható xml parser ([ez pl. free]), vagy Office ([ezt pl.]) csomagot.
Kellemes codeorgást...
-
Pakliman
tag
válasz
fogtunder
#39252
üzenetére
Nálunk a cégnél is lecserélték a gépemet egy win10-es rendszerűre (ez nem lenne gond, a laposomon is az van), amire az Office 2016-ot rakták.
Elég sok munkafüzetem van, ami tele van makrókkal és képletekkel, soha nem volt probléma velük, normálisan lehetett velük dolgozni. A 2016-os ofisz viszont betett mindennek, rendszeresek a fagyások, a hosszú percekig tartó megnyitások, szükségtelen újraszámolások, "A Microsoft Excel működése leállt. Újraindítsuk? Anyádat!!!". És a lényeg, iszonyatosan laggol, a sorok közötti mozgás is!!
Kértem vissza az Office 2010-et, de hát ugye cég, nem adják
Tehát: nem hálózati gond, nem gép gond -> az ofisz2016 egy rakás fxs -
Pakliman
tag
válasz
GreenIT
#39216
üzenetére
Segítség leginkább az utóirathoz.
A Kezd és Végez paraméter EGÉSZ!!szám (pl.: 2352) és idő formátumot is tud kezelni.
A függvény kezeli az egyik napról a másikra átnyúló időt.
Mindhárom fv használható makróban és cellában is.Public Function ElteltIdő(Kezd, Végez, Optional bVisszaPercben As Boolean = True)
Dim xKezd As Long
Dim xVégez As Long
If IsDate(Kezd) Then
xKezd = (Hour(Kezd) * 60) + Minute(Kezd)
Else
xKezd = NtoP(CLng(Kezd))
End If
If IsDate(Végez) Then
xVégez = (Hour(Végez) * 60) + Minute(Végez)
Else
xVégez = NtoP(CLng(Végez))
End If
If xVégez < xKezd Then xVégez = xVégez + 1440
ElteltIdő = IIf(bVisszaPercben, xVégez - xKezd, PtoN(xVégez - xKezd))
End Function
Public Function NtoP(szám) As Long
'1234 formátumú (12 óra 34 perc) számot kell megadni
'Az eredmény a percek száma
'Pl.: NtoP(123)=83 (1 óra 23 perc = 83 perc)
NtoP = ((szám \ 100) * 60) + (szám Mod 100)
End Function
Public Function PtoN(szám) As Long
'Perceket kell megadni
'Az eredmény egy 1234 formátumú (12 óra 34 perc) szám
'Pl.: PtoN(83)=123 (1 óra 23 perc)
PtoN = ((szám \ 60) * 100) + (szám Mod 60)
End Function -
Pakliman
tag
válasz
Winner_hun
#38653
üzenetére
Excel 2016-ban Menü/Oldalbeállítás/Nyomtatási címkék -> Munkalap fül -> Fent ismétlődő sorok.
A színezés tudomásom szerint csak úgy, ha Te színezed. -
Pakliman
tag
válasz
dori0495
#38592
üzenetére
Ahogy [Fferi50] írta, UserForm-mal.
Ha már dolgoztál vele, akkor szerintem ez lenne a legegyszerűbb.Ha nem, akkor egy lehetséges megoldás:
Mivel ha jól látom, már van egy statisztika munkalap (legyen a neve "Statisztika"), ezért használjuk azt.Feltételezve, hogy az adatokat tartalmazó munkalap neve "Adatok", a kódmoduljába be kell írni:
(A kiválasztott sor DK oszlopában duplán kattintva fog lefutni a kód.)Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If (Target.Row > 3) And (Target.Column = Range("DK1").Column) Then
With Worksheets("Statisztika")
Cancel = True
.Activate
.Range("F2") = Target.Row
End With
End If
End SubA "Statisztika" munkalapra kell egy segédoszlop (mondjuk legyen az "F")
Az "F2" cella fogja tartalmazni annak a sornak a számát, amin állva duplán kattintottál.
A 3. sortól kezdve azoknak az oszlopoknak a betűjelét kell oda beírni, amelyikben megtalálható az adott adat.
A "C" oszlop tartalma (már ahol éppen nem számított érték van, mint pl. "Szerszámok elkészítésének ideje"):
=HA(ÜRES(F3);"";INDIREKT("Adatok!" & F3 & $F$2)). -
Pakliman
tag
válasz
Peddy789
#38297
üzenetére
Üdv!
Valami ilyesmi módon IS lehet:
Public Sub Kitölt()
Dim sor1 As Long
Dim sor2 As Long
Dim sor3 As Long
Dim sFile As String
Dim FF As Long
Dim temp
Set ws1 = ThisWorkbook.Worksheets(1)
Set ws2 = ThisWorkbook.Worksheets(2)
Set ws3 = ThisWorkbook.Worksheets(3)
sFile = "c:\A szövegfálj.txt"
FF = FreeFile
Open sFile For Input Access Read Shared As #FF
Do While Not EOF(FF)
Line Input #FF, temp
Select Case Left(temp, 3)
Case "MB1": sor1 = sor1 + 1: ws1.Cells(sor1, 1) = temp
Case "MB2": sor2 = sor2 + 1: ws2.Cells(sor2, 1) = temp
Case "MB3": sor3 = sor3 + 1: ws3.Cells(sor3, 1) = temp
End Select
Loop
Close #FF
End SubTermészetesen ez egy elnagyolt kód, lehet még rajta finomítani bőven
-
Pakliman
tag
Szia!
Ezzel kísérletezhetsz:
Public Sub KépBerak(sKép As String, ml As Worksheet, dLeft As Double, dTop As Double, dWidth As Double, dHeight As Double)
With ml.Pictures
With .Insert(sKép)
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Left = dLeft
.ShapeRange.Top = dTop
.ShapeRange.Width = dWidth
.ShapeRange.Height = dHeight
End With
End With
End Sub -
4) az adott hónapot
)
Új hozzászólás Aktív témák
- Milyen asztali (teljes vagy fél-) gépet vegyek?
- Linux kezdőknek
- Xiaomi 11 Lite 5G NE (lisa)
- Háztartási gépek
- One otthoni szolgáltatások (TV, internet, telefon)
- Battlefield 6
- iPhone topik
- Bambu Lab 3D nyomtatók
- Samsung Galaxy A56 - megbízható középszerűség
- One mobilszolgáltatások
- További aktív témák...
- Azonnali készpénzes AMD CPU AMD VGA számítógép felvásárlás személyesen / postával korrekt áron
- 174 - Lenovo Legion Pro 7 (16IAX10H) - Intel Core U9 275HX, RTX 5070Ti
- Apple iPhone 16 Pro Max 256GB, Kártyafüggetlen, 1 Év Garanciával
- Azonnali készpénzes Sony Playstation 4 Slim / PS4 Pro felvásárlás személyesen/csomagküldéssel
- BESZÁMÍTÁS! Intel Core i7 8700K 6 mag 12 szál processzor garanciával hibátlan működéssel
Állásajánlatok
Cég: Promenade Publishing House Kft.
Város: Budapest
Cég: NetGo.hu Kft.
Város: Gödöllő