-
Mobilarena
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
-
#14452
Delila_1
veterán
foregister
#14449
Delila_1
veterán
válasz
foregister
#14449
üzenetére
Szívesen, örülök, hogy tetszik.
-
Delila_1
veterán
válasz
lacid90
#14446
üzenetére
Szívesen.
Ha megint leáll valami hasonló hiba miatt, a VB szerkesztőben állva adj egy Ctrl+G-t, mire jobb oldalon lent kapsz egy kis ablakot. Oda másold be a Application.EnableEvents = True sort. és adj neki Entert. Újra fut majd a makród.
A 14395-re:
A változókat publikusként add meg a makró fölött, akkor mindegyik makród eléri.
Public változó As Integer
Public tömb(10,2) -
Delila_1
veterán
válasz
lacid90
#14444
üzenetére
Egy fölöttébb fárasztó pihenésem volt...
Egy laphoz rendelt, eseményvezérelt makró megoldja.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [A:A]) Is Nothing Then
Application.EnableEvents = False
Cells(Target.Row, "A") = Round(Target.Value / 5, 0) * 5
Application.EnableEvents = True
End If
End SubEz az A oszlopba bevitt értékeket figyeli árgus szemekkel {If Not Intersect(Target, [A:A]) Is Nothing Then}, és a bevitel sorába írja a kerekített értéket {Cells(Target.Row, "A") = Round(Target.Value / 5, 0) * 5}.
-
#14443
Delila_1
veterán
foregister
#14442
Delila_1
veterán
válasz
foregister
#14442
üzenetére
Az F1 és F2 cellákba vittem be a két szöveget. Az F1-nek K nevet adtam, az F2-nek NK-t, a kettőnek együtt Kettő-t.
A C1:C3 tartományba vittem be érvényesítést, de nem egyformát. Mindegyik mellé beírtam az érvényesítés képletét.
-
#14339
Delila_1
veterán
marchello1
#14333
Delila_1
veterán
válasz
marchello1
#14333
üzenetére
Esetleg megfordítva, hasáb helyett sávdiagram.
A felső sor feltételes formázásának a képlete B1-től G1-ig: =$A1>OSZLOP()-2.Itt a háttér piros, a szegély körben fehér.
A második sor képlete: =$A2>OSZLOP()-2. Itt csak a háttér színe tér el.
Nem szükséges szegélyt adni. -
Delila_1
veterán
-
#14320
Delila_1
veterán
foregister
#14319
Delila_1
veterán
válasz
foregister
#14319
üzenetére
Az Adatok lap B2 cellája legyen
=INDEX(Szótár!A:B,MATCH(B2,Szótár!A:A,0),2)
Ezt lemásolod, majd felülírod vele a B oszlopot. Ne a képletet másold, hanem az értékét tedd be irányítottan a B-be.
-
Delila_1
veterán
válasz
lacid90
#14275
üzenetére
Az A:F oszlopok hátterét vizsgálja a makró. Ha a teljes sort akarod ellenőriztetni, a Range("A" & sor & ":F" & sor) helyett ezt írd be: Range(Cells(sor, 1), Cells(sor, Columns.Count)) .
Sub Szines()
Dim CV As Object, sor As Integer
sor = ActiveCell.Row
For Each CV In Range("A" & sor & ":F" & sor)
If CV.Interior.ColorIndex <> -4142 Then
MsgBox "Van színes hátterű cella"
Exit Sub
End If
Next
MsgBox "Nincs színes hátterű cella"
End Sub -
Delila_1
veterán
válasz
79blueboy
#14272
üzenetére
A laphoz kell rendelned a kódot. A makró a C3 cellát zárolja, és a lapot az "aaa" jelszóval védi.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("C3")) Is Nothing Then
Range("C3").Locked = True
ActiveSheet.Protect Password:="aaa"
End If
End Sub -
Delila_1
veterán
Vegyük, hogy a Munka2 (stb.) lapon az F oszlopba írod a végrehajtás dátumát. Az összesítő lap F oszlopába kerül az =HA(Munka2!F1<>"";1;0) képlet. A formázandó oszlop feltételes formázása az =F1=1 képlettel oldható meg.
Másik lap befejezett feladatához másik oszlopot használhatsz.
-
-
Delila_1
veterán
válasz
buherton
#14010
üzenetére
Az A1:A10 tartomány rövidítését beírja a B1:B10 tartományba, és megvizsgálja a COUNTIF (darabteli) függvénnyel, hogy hány db ilyen van a B oszlopban. Ha 1-nél több, akkor a B oszlopba az A megfelelő cellájának az első és harmadik betűjét írja. Lehetne cifrázni, mert előfordulhat, hogy több azonos alakul ki így is. Ahhoz újabb ciklusok kellenek, egy Do-Loop, és egy For-Next. Ha több időm lesz, és szükséges, megírom.
Sub rovidites()
Dim sor%, szo$, betu%
For sor% = 1 To 10
szo$ = Cells(sor%, "A")
If InStr(1, szo$, " ") Then 'ha van benne szóköz
For betu% = 1 To Len(szo$)
If Asc(Mid(szo$, betu%, 1)) > 64 And Asc(Mid(szo$, betu%, 1)) < 91 Then 'nagybetű
Cells(sor%, "B") = Cells(sor%, "B") & Mid(szo$, betu%, 1)
End If
Next
Else
Cells(sor%, "B") = Left(szo$, 2)
End If
If WorksheetFunction.CountIf(Columns(2), Cells(sor%, "B")) > 1 Then _
Cells(sor%, "B") = Left(szo$, 1) & Mid(szo$, 3, 1)
Next
End Sub -
Delila_1
veterán
-
#13996
Delila_1
veterán
lizakattila
#13995
Delila_1
veterán
válasz
lizakattila
#13995
üzenetére
Készíts kimutatást. A SOR-hoz tedd az oszlopod címét, és ugyanazt az ADAT-hoz is (2003-as verzió), ahol a darabszámot kéred, és máris kész.
2007-es verzióban a címet a SORCÍMKÉK-hez és az ÉRTÉKEK-hez tedd.
-
Delila_1
veterán
válasz
AlyArkhon
#13975
üzenetére
Javaslom, hogy a napok számát az A oszlopban az összegző sor elejére írd.
Kijelölöd a példád szerinti 1:5 sort, Adatok | Tagolás | Csoportba foglalás.Újabb kijelölés (8:11 sor), F4 billentyűre ismétli a csoportba foglalást. Ugyanezzel a módszerrel foglald csoportba a többit is.
A sorazonosítók mellett balra "-" jelek jelentek meg, ezekre kattintva egyenként bezárhatod az adatokat tartalmazó sorokat. A balra fent lévő egyesre kattintva minden napnak csak az összesítő sora látszik, a kettes kibontja a sorokat.
A C2 képletét átírtam.
Szerk.: először véletlenszámokat vittem az E34:J38 tartományba, később írtam be a rendes értékeket. A képletet csak a G oszlopig másoltam, azért vannak a H oszlopban hamis adatok, ne törődj vele!
-
#13958
Delila_1
veterán
Metathrone
#13956
Delila_1
veterán
válasz
Metathrone
#13956
üzenetére
A függvények, képletek beírását "=" , vagy "+" jellel kell kezdeni. Ha "+" jellel kezded, akkor az Excel önállóan írja be elé az "=" jelet, akkor lesz a függvény, vagy képlet elején "=+". Az eredmény ugyanaz.
-
#13949
Delila_1
veterán
Metathrone
#13948
Delila_1
veterán
válasz
Metathrone
#13948
üzenetére
Ezt akkor tudod automatikusan megoldani, ha a billentyűzettel törlöd a cellák tartalmát. Ha 1 db makród van a 6 cellához, akkor a lenti makrót másold a lapod kódlapjára.
Private Sub Worksheet_Change(ByVal Target As Range)
If IsEmpty(Target) And (Target.Address = "$B$10" Or Target.Address = "$C$3" Or _
Target.Address = "$D$12") Then
Makró_neve
End If
End SubÉn csak 3 címet írtam be (B10, C3 és D12), ezt egészítsd ki 6-ra, és a saját címeidre.
Ha a 6 kiürített cellának más-más makrókat kell indítaniuk, akkor a következőt másold a lapod kódlapjára.Private Sub Worksheet_Change(ByVal Target As Range)
If IsEmpty(Target) Then
Select Case Target.Address
Case "$B$10"
Makró_1
Case "$C$3"
Makró_2
Case "$D$12"
Makró_3
'.
'.
'.
End Select
End If
End SubItt is csak 3 címet adtam meg. Az indítandó makrók címe nálam Makró_1, Makró_2, és Makró_3.
-
#13877
Delila_1
veterán
m.zmrzlina
#13876
Delila_1
veterán
válasz
m.zmrzlina
#13876
üzenetére
Azért tettem csillagot a hol.van függvény feltételének az elejére is.
Kiegészítheted az INDEX függvénnyel:
=INDEX(H:H;HOL.VAN("*"&BAL(I1;2)&"*";H:H;0);1)
ami az I mellé írja a H oszlopban lévő megfelelőjét, de mint írtam, nem lesz teljesen jó, csak ad némi támaszt.
-
#13875
Delila_1
veterán
m.zmrzlina
#13874
Delila_1
veterán
válasz
m.zmrzlina
#13874
üzenetére
Valami ilyen segíthet, de nem 100%-os:
=HOL.VAN("*"&BAL(I1;2)&"*";H:H;0)
Ahol az I oszlopban nincs adat, ott 1-et ír találati helynek.
-
Delila_1
veterán
válasz
hallgat
#13831
üzenetére
Ha a Munka2 lap L oszlopának az aljára akarod bemásolni ismételten a Munka1!B1:T1 tartományát, akkor az usor változót ehhez kell igazítani.
Sub mm()
Dim usor As Integer
'Munka1!B1:T1 másolása a Munka2!L2-be transzponálva
Sheets("Munka1").Range("B1:T1").Copy
Sheets("Munka2").Select
Range("L2").Select
Selection.PasteSpecial Paste:=xlValues, Transpose:=True
'usor az L oszlopban a Munka2 lapon
usor = Range("L65536").End(xlUp).Row
'másolás az utolsó alatti sorba, transzponálva
Range("L" & usor + 1).Select
Selection.PasteSpecial Paste:=xlValues, Transpose:=True
End Sub -
Delila_1
veterán
válasz
hallgat
#13831
üzenetére
Ha a Munka2 lap L oszlopának az aljára akarod bemásolni ismételten a Munka1!B1:T1 tartományát, akkor az usor változót ehhez kell igazítani.
Sub mm()
Dim usor As Integer
'Munka1!B1:T1 másolása a Munka2!L2-be transzponálva
Sheets("Munka1").Range("B1:T1").Copy
Sheets("Munka2").Select
Range("L2").Select
Selection.PasteSpecial Paste:=xlValues, Transpose:=True
'usor az L oszlopban a Munka2 lapon
usor = Range("L65536").End(xlUp).Row
'másolás az utolsó alatti sorba, transzponálva
Range("L" & usor + 1).Select
Selection.PasteSpecial Paste:=xlValues, Transpose:=True
End Sub -
-
Delila_1
veterán
A makró törli az előző színezést, bekéri a szélességet, majd a magasságot, és ennek megfelelően színezi a területet.
Rosszul írtad, a 80 cm nem a T, hanem az X oszlopig tart.Sub Ter()
Dim sz%, m%
Range("1:255").Interior.ColorIndex = -4142
sz% = Int(InputBox("Kérem a szélességet cm-ben", "Szélesség", Default) / 5)
m% = Int(InputBox("Kérem a magasságot cm-ben", "magasság", Default) / 5)
Range(Cells(1), Cells(m%, sz%)).Interior.ColorIndex = 5
End SubKitehetsz hozzá egy gombot.
-
Delila_1
veterán
-
#13733
Delila_1
veterán
Bocimaster
#13731
Delila_1
veterán
válasz
Bocimaster
#13731
üzenetére
Ha tényleg tetszik, jó, ha nem, a makró elejére írd be:
Application.DisplayAlerts = False, a végére Application.DisplayAlerts = True.
-
Delila_1
veterán
válasz
Bazunga
#13730
üzenetére
A másik füzetet "Másik füzet"-nek neveztem el, írd át a makróban. Célszerű a Replace funkcióval, akkor nem marad ki egy sem.
A "Hetek más füzetbe" Munka1 lapján a cellák egyesítését megszüntettem, mert ezek hibát okoznak a másolásnál. Helyette a kijelölt cellák vízszintes elrendezésénél "A kijelölés közepére" formát alkalmaztam. Ez minden más füzetre is érvényes, ha csak lehet, kerüld az egyesítést.
A Module3 létrehoz egy új füzetet 53 számozott lappal (jövőre jó lesz).
-
-
Delila_1
veterán
Sub alma()
Dim sor%, usor%, oszlop%, potsor
usor = Range("A1").End(xlDown).Row: potsor = usor% + 1
For sor% = 1 To usor%
oszlop% = Cells(sor%, 200).End(xlToLeft).Column
Do While oszlop > 2
If oszlop% > 2 Then
Cells(potsor, 1) = Cells(sor%, 1)
Cells(potsor, 2) = Cells(sor%, oszlop)
Cells(sor%, oszlop%) = ""
potsor = potsor + 1: oszlop% = oszlop% - 1
End If
Loop
Next
End Sub -
#13691
Delila_1
veterán
Fire/SOUL/CD
#13690
Delila_1
veterán
válasz
Fire/SOUL/CD
#13690
üzenetére
Ez nem ok a hiányzásra. Ennél sokkal komolyabb dolgaim vannak, mégis jelen vagyok. olykor-olykor.
![;]](//cdn.rios.hu/dl/s/v1.gif)
-
#13689
Delila_1
veterán
Fire/SOUL/CD
#13688
Delila_1
veterán
válasz
Fire/SOUL/CD
#13688
üzenetére
Ideje már, hogy megtiszteled a fórumot a jelenléteddel!
Igazolást kell hoznod a távolléted okáról. -
Delila_1
veterán
válasz
Bazunga
#13684
üzenetére
Alt+F11-gyel behívod a VB szerkesztőt. Bal oldalon kiválasztod a füzetedet. Insert menü, Module. Bal oldalon a füzetedben megjelenik egy Module1 nevű modul, mikor ezt kiválasztod, jobb oldalon kapsz egy üres lapot. Na oda másold be a kódok valamelyikét, és már alakíthatod is kedvedre. F5-tel indítható.
A füzetedben Alt+F8 hozza be a makrókat, amiket indíthatsz. Tehetsz ki egy gombot pl. az űrlap eszköztárról, rajta jobb klikk, és a Makróhozzárendelés gombbal illesztheted a kitett gombhoz a kódot.
-
#13678
Delila_1
veterán
Bocimaster
#13675
Delila_1
veterán
válasz
Bocimaster
#13675
üzenetére
Sub Korhaz()
Dim sor As Double, usor As Double, nev$
Dim WB As Workbook
Dim utvonal$, lap%
Application.ScreenUpdating = False
utvonal = "E:\Eadat\" 'itt írd be a saját útvonaladat ehelyett, ügyelj a \ jelekre
Set WB = Workbooks("Gyerek és subspec ágyak végl.xlsm")
usor = Cells(Rows.Count, "A").End(xlUp).Row
For sor = 4 To usor
nev$ = Cells(sor, 4) & ".xlsx" 'D oszlopban lévő név a nev$ változóba
Workbooks.Add 'az új füzetet el is mentjük
ActiveWorkbook.SaveAs Filename:=utvonal & nev$, FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
WB.Sheets(1).Range("1:3").Copy Range("A1") '1:3 sor másolása
WB.Sheets(1).Rows(sor).Copy Range("A4") 'sor-adik sor másolása
'újabb mentés a bemásolt adatokkal
ActiveWorkbook.SaveAs Filename:=utvonal & nev$, FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close 'füzet bezárása
Next
Application.ScreenUpdating = True
End SubAz "A D oszlopban az intézeteket egyesével kimásolni minden egyes intézet külön fájlba és az intézet névvel elmentve.." nem egészen világos nekem. Arra gondoltál, hogy az egyes intézetek teljes sorát kell másolni? Úgy írtam meg a makrót.
A makró bemásolása után makróbarátként kell mentened a füzetet, a kiterjesztése xlsm lesz. Ez szerepel a Set kezdetű sorban.
-
Delila_1
veterán
válasz
slashing
#13671
üzenetére
A második kérdésedre próbálok válaszolni.
Megfordítottam a sorokat és oszlopokat, mert dátumból jóval több lesz, mint az egyéb adatokból, szerintem így jobban átlátható.
Hasraütéssel határoztam meg a délutános-, éjszakai-, és vasárnapi pótlékokat a P1:P3 tartományban. A zöld hátterű részt kell kiállítani, a H:M adja az eredményt, ahol az M értékeit kell az órabérrel felszorozni.
Szerk.: 12 órás éjszakai műszakról nem írtál, mert valószínűleg nem alkalmazzátok.
-
#13668
Delila_1
veterán
Bocimaster
#13667
Delila_1
veterán
válasz
Bocimaster
#13667
üzenetére
A napokban írtam valakinek erre a feladatra egy makrót. Nála az azonosító, ami Nálad a telephely, az A oszlopban van.
A makró telephelyenként szétdobja külön lapokra a Munka1 lap adatait, majd minden lapot áttesz külön füzetbe, és a telephely nevén lementi. Írtam bele megjegyzéseket, aszerint módosíts a makrón.
Sub Telephelyek()
Dim sor As Double, usor As Double, usor_1 As Double, nev$, WS1 As Worksheet
Dim utvonal$, lap%
Application.ScreenUpdating = False
Application.DisplayAlerts = False
utvonal = "E:\Eadat\" 'itt írd be a saját útvonaladat ehelyett, ügyelj a \ jelekre
usor = Cells(Rows.Count, "A").End(xlUp).Row
Set WS1 = Sheets("Munka1") 'ide jön a saját indító lap%od neve
'Másolás lap%okra
For sor = 2 To usor
nev$ = WS1.Cells(sor, 1)
On Error GoTo Uj_lap
usor_1 = Sheets(nev$).Cells(Rows.Count, "A").End(xlUp).Row + 1
'a következő 2 sorban írd át a "K"-t az utolsó oszlopod azonosítójára
If usor_1 = 2 Then Range(WS1.Cells(1, "A"), WS1.Cells(1, "K")).Copy Sheets(nev$).Cells(1)
Range(WS1.Cells(sor, "A"), WS1.Cells(sor, "K")).Copy Sheets(nev$).Cells(usor_1, "A")
Next
'**********************************************************************************************
'Ha nem kell külön füzetekbe menteni a lapokat, ezt a részt hagyd ki
'Mentés, zárás
For lap% = 1 To Sheets.Count - 1
nev$ = utvonal & Sheets(1).Cells(2, "A")
Sheets(1).Move
ActiveWorkbook.SaveAs Filename:=nev$, FileFormat:=xlNormal _
, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
ActiveWindow.Close
Next
'**********************************************************************************************
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Kész"
Exit Sub
Uj_lap:
If Err = 9 Then
Worksheets.Add.Name = nev$
Resume 0
Else
Error Err
End If
End Sub -
#13661
Delila_1
veterán
MasterMark
#13660
Delila_1
veterán
válasz
MasterMark
#13660
üzenetére
Ha az A1 cellában van a születési dátum, a képlet =MA()-A1. A képletet tartalmazó cella formátuma általános, vagy szám formátumú legyen.
-
-
Delila_1
veterán
Egy példával próbálok segíteni.
Van egy vállalati hierarchia:
Legnagyobb főnök
Nagyfőnök
Közepes főnök
Kisfőnök
BeosztottHa rendezed, az eredmény
Beosztott
Kisfőnök
Közepes főnök
Legnagyobb főnök
NagyfőnökLegközelebb az össze-vissza bevitt beosztásokat az első sorrendben szeretnéd látni. A tennivaló, hogy az eredeti sorrendben bevitt adatokat bemásolod az egyéni listák közé. A rendezésnél kiválasztod az Egyebeket, ott pedig az Első kulcs szerinti rendezésnél a bevitt listádat. Két OK, és visszaáll a sorrend az eredeti bevitel szerintire.
Lehet, hogy a második ID-idet kellene bevinni egyéni listaként, és az első ID-ket eszerint rendezhetnéd.
-
Delila_1
veterán
válasz
Bazunga
#13649
üzenetére
Az érvényesítés az A2 cellában van. A D1:J1 tartomány adja meg, hogy az aktuális hét hányadik napjának a dátumát kéred a D2:J2 tartományban.
Az L oszlopba tettem az év napjait. Az M1 képlete:
=HA(HÉT.NAPJA(DÁTUM(ÉV(L1);1;1);2)>3;WEEKNUM(L1;2)-1;WEEKNUM(L1;2))A D1 cella képlete:
=INDEX($L:$M;HOL.VAN($A$2;$M:$M;0)+D$1-1;1) -
Delila_1
veterán
válasz
dabgergo
#13645
üzenetére
Ez a bill. kombinációs hiba úgy látom, általános, és nem megfogható. Több helyen olvastam, hogy a gépre telepített más programok okozzák, de mindenki más-más programot okol.
Most találtam egy ilyent: "Makróval is el lehet állítani a billentyűkombinációkat, de úgy is hogy be van kapcsolva a Lotus kompatibilitásnál (Beállítások / Speciális) a másodlagos irányító billentyűk opció." Egy próbát megér.
-
#13627
Delila_1
veterán
terencehill
#13624
Delila_1
veterán
válasz
terencehill
#13624
üzenetére
Szívesen.
-
#13623
Delila_1
veterán
terencehill
#13622
Delila_1
veterán
válasz
terencehill
#13622
üzenetére
Az F oszlopban fűzd össze a B2:E2 tartományt, az adatok között szóközzel.
F2 -> =B2&" "&C2&" "&D2&" "&E2 Ezt lemásolod az utolsó sorig.
G2 -> =DARABTELI(F:F;F2) Ezt is lemásolod, minden sor mellett kiírja a darabszámot.
A diagramhoz a G oszlopból kiszűrheted az egyéni értékeket. 2003-as verzióig irányított szűréssel, fölötte vagy a speciális szűréssel (ami azonos az előbbivel), vagy az ismétlődések eltávolításával. A művelet előtt érdemes a G oszlop képleteit értékké alakítani irányított beillesztéssel.
-
#13621
Delila_1
veterán
Bocimaster
#13619
Delila_1
veterán
válasz
Bocimaster
#13619
üzenetére
A 2. sorban: =ha(a2="Összesen";"";ide_jön_az_előző_képlet)
-
#13620
Delila_1
veterán
Bocimaster
#13619
Delila_1
veterán
válasz
Bocimaster
#13619
üzenetére
Csatolj egy képet a lapról, mert ebből nem nagyon látszik, mi a gond.
-
#13616
Delila_1
veterán
Bocimaster
#13615
Delila_1
veterán
válasz
Bocimaster
#13615
üzenetére
Milyen fontot töltöttél le?
-
#13614
Delila_1
veterán
Bocimaster
#13613
Delila_1
veterán
válasz
Bocimaster
#13613
üzenetére
Nem kell az ÖSSZEFŰZ szó.
Vagy =ÖSSZEFŰZ(A1;B1), vagy =A1&B1. Aki keresgéli a billentyűket, mint én, spóroljon a gépeléssel.
-
#13610
Delila_1
veterán
Bocimaster
#13607
Delila_1
veterán
válasz
Bocimaster
#13607
üzenetére
=BAL(G2&"____________";7)&BAL(H2&"______";5) &BAL(K2&"_____________";20)&BAL(U2&"________";10)&V2
Ha az i és a m karakter azonos szélességű lenne, ez a képlet szépen összehozná. Olyan betűtípust kell választanod, ami nem szép ugyan, de teljesíti ezt a feltételt.
A BAL függvényben Te határozd meg az egyes hosszakat. -
Delila_1
veterán
Régebbi hozzászólásokból tallóztam össze.
Private Declare Function PlaySound Lib "winmm.dll" _
Alias "PlaySoundA" (ByVal lpszName As String, _
ByVal hModule As Long, ByVal dwFlags As Long) As Long
Const SND_SYNC = &H0
Const SND_ASYNC = &H1
Const SND_FILENAME = &H20000
Sub PlayWAV()
utvonal = "E:\Utvonal\" 'Itt módosíts
WAVFile = utvonal & "\" & "Fáljnév.wav" 'meg itt is
Call PlaySound(WAVFile, 0&, SND_SYNC Or SND_FILENAME)
End SubA most PlayWAV rutin sorait eseményvezéreltként vidd be.
-
-
Delila_1
veterán
Ez a makró megcsinálja. Előbb új lapokra másolja az egyes sorokat, mindegyiket olyan nevű lapra, amilyen adatot tartalmaz az adott sor első (A) cellája.
Ezután az egyes lapokat áthelyezi 1-1 új fájlba, aminek a neve a lapnév + "_adott adat".Az utvonal = "E:\Eadat\" sorban írd át az útvonalat a sajátodra, a végén is legyen \ jel, mint itt.
A nev$ = utvonal & Sheets(1).Name & "_adott adat.xls" sor végén az .xls helyett írj .xlsx-et, ha 2003-asnál magasabb verziót alkalmazol.Címsort feltételezek, ezért az első ciklust (sorok másolása másik lapokra) a 2. sortól kezdtem a For sor% = 2 To usor% sorban. Címsor nélkül legyen ez a sor For sor% = 1 To usor%.
Sub Ujak()
Dim sor%, usor%, usor_1%, nev$, WS1 As Worksheet
Dim utvonal$, lap%
Application.ScreenUpdating = False
Application.DisplayAlerts = False
utvonal = "E:\Eadat\" 'Itt írd be a saját útvonaladat ehelyett
usor% = Cells(Rows.Count, "A").End(xlUp).Row
Set WS1 = Sheets("Kezdőlap")
For sor% = 2 To usor%
nev$ = WS1.Cells(sor%, "A")
On Error GoTo Uj_lap
usor_1% = Sheets(nev$).Cells(Rows.Count, "A").End(xlUp).Row + 1
WS1.Rows(sor%).Copy Sheets(nev$).Cells(usor_1%, "A")
Next
For lap% = 1 To Sheets.Count - 1
nev$ = utvonal & Sheets(1).Name & "_adott adat.xls"
Sheets(1).Move
ActiveWorkbook.SaveAs Filename:=nev$, FileFormat:=xlNormal _
, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
ActiveWindow.Close
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Kész"
Exit Sub
Uj_lap:
If Err = 9 Then
Worksheets.Add.Name = nev$
Resume 0
Else
Error Err
End If
End Sub -
Delila_1
veterán
válasz
ThaBoss
#13577
üzenetére
Ha milliós sorszámod van, módosítani kell a makrón. A % jelet vedd le a változók végéről, és a Dim kezdetű sorokban így add meg: Dim sor As Double.
A % jellel a végén azonos a Dim sor As Integer-rel, de ez csak -32.768 és 32.767 közötti értékekre jó, ezen a tartományon kívül hibára futna.
, mert ez így túl egyszerű.
![;]](http://cdn.rios.hu/dl/s/v1.gif)
Új hozzászólás Aktív témák
Hirdetés
- Jogtiszta Microsoft Windows / Office / Stb.
- LG 27GR93U-B - 27" IPS - UHD 4K - 144Hz 1ms - NVIDIA G-Sync - FreeSync Premium - HDR 400
- Steam, EA, Ubisoft és GoG játékkulcsok, illetve Game Pass kedvező áron, egyenesen a kiadóktól!
- SanDisk Extreme Portable 8TB (SDSSDE61-8T00-G25)
- Így lesz a Logitech MX Keys magyar billentyűzetes
Állásajánlatok
Cég: PC Trade Systems Kft.
Város: Szeged
Cég: PC Trade Systems Kft.
Város: Szeged