- Bemutatkozott a Transcend SSD-inek zászlóshajója
- Sugárhajtómű ihlette a Zalman CPU-hűtőjét, de nem az üzemzaj tekintetében
- Félreértések az FSR 4 és a PlayStation 5 Pro körül
- Nem tetszik a Procon-SP-nek, hogy a Nintendo távolról kivégezheti a Switch 2-t
- Megcélozta az NVIDIA-t a 2 nm-es node-jával a Samsung
-
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
-
Oly
őstag
válasz
Delila_1
#32456
üzenetére
Szia
Tovább gondoltam az általad vázolt megoldás.
Ez lett belőle:
Dim usor As Long, sor As Long, hova As Long, hol, WF As WorksheetFunction
Set WF = Application.WorksheetFunction
'tegnap volt, de ma nincs
usor = WF.CountA(Columns(1))
For sor = 2 To usor
hova = WF.CountA(Columns(11)) + 1
hol = Application.Match(Cells(sor, "A") & Cells(sor, "B"), Range("N:N"), 0)
If VarType(hol) = vbError Then
Range("A" & sor & ":B" & sor).Copy Range("K" & hova)
Cells(hova, "M") = 0
On Error GoTo 0
End If
Next
'változók listája tegnaphoz képest
usor = WF.CountA(Columns(11))
For sor = 2 To usor
hova = WF.CountA(Columns(7)) + 1
hol = Application.Match(Cells(sor, "K") & Cells(sor, "L") & Cells(sor, "M"), Range("E:E"), 0)
If VarType(hol) = vbError Then
Range("K" & sor).Copy Range("G" & hova)
End If
Next
'nem változott tételek törlése a mai listában
usor = WF.CountA(Columns(11))
For sor = 2 To usor
hol = Application.Match(Cells(sor, "K"), Range("G:G"), 0)
If VarType(hol) = vbError Then
Range("K" & sor & ":O" & sor).Value = ""
End If
NextAz a kérdésem, hogy a Match-ben a Lookup_array Range-re tudok valahogy dinamikusan hivatkozni, mint ahogy a Lookup_value-nál tettem?
Ez azért lenne fontos, hogy ne kelljen kiegészítő oszlopot létrehozni a táblák mellett.Előre is köszi, oly
-
Delila_1
veterán
3 makrót írtam. Az első sorra veszi a B oszlop celláit. Ha még nincs ennek megfelelő lap a füzetben, létrehozza, átmásolja a címsort és az aktuális sort. Az új lap neve az aktuális sor B oszlopában lévő adat lesz. Ha már van ilyen nevű lap, az első üres sorába másolja az aktuális sort. Nem kell az első lapon rendezettnek lennie a táblának.
A második sorra veszi a lapokat a másodiktól az utolsóig, Új füzetbe másolja az aktuális lapot, ezt elmenti a lapnév nevével az utvonal nevű változóban megadott mappába. Ezt a makró elején kell átírnod az
utvonal = "C:\Temp\"
sorban a saját mentési útvonaladra.Ha az eredeti füzetben nem akarod megtartani az újonnan létrehozott lapokat, akkor a második helyett a harmadik makrót futtasd. Ez nem másolja, hanem áthelyezi a lapokat 1-1 új füzetbe. Itt is át kell írnod az utvonal változó értékét.
A két másolós makró feltételezi, hogy kezdetkor 1 lap volt a füzetedben.
Sub Kulon_Lapra()
Dim sor As Long, lapnev As String, a, hova As Long, WS1 As Worksheet
Application.ScreenUpdating = False
Set WS1 = ActiveSheet
sor = 2
Do While Cells(sor, 1) <> ""
lapnev = Cells(sor, "B")
On Error Resume Next
Set a = Sheets(lapnev)
If Err.Number <> 0 Then
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = lapnev
WS1.Rows(1).Copy Sheets(lapnev).Cells(1)
WS1.Activate
End If
On Error GoTo 0
hova = Application.WorksheetFunction.CountA(Sheets(lapnev).Columns(1)) + 1
Rows(sor).Copy Sheets(lapnev).Cells(hova, 1)
sor = sor + 1
Loop
Application.ScreenUpdating = True
End SubSub LapMentes()
Dim lap As Long, utvonal As String, lapnev As String
utvonal = "C:\Temp\"
Application.ScreenUpdating = False
For lap = 2 To Sheets.Count
lapnev = Sheets(lap).Name
Sheets(lapnev).Copy
ActiveWorkbook.SaveAs Filename:=utvonal & lapnev & ".xlsx"
ActiveWorkbook.Close
Next
Application.ScreenUpdating = True
End SubSub MentTorol()
Dim lap As Long, utvonal As String, lapnev As String
utvonal = "C:\Temp\"
Application.ScreenUpdating = False
For lap = Sheets.Count To 2 Step -1
lapnev = Sheets(lap).Name
Sheets(lapnev).Move
ActiveWorkbook.SaveAs Filename:=utvonal & lapnev & ".xlsx"
ActiveWorkbook.Close
Next
Application.ScreenUpdating = True
End Sub -
Sprite75
tag
válasz
Delila_1
#32352
üzenetére
Átolvasgattam mindent amit annak idején Fferi50 - el írogattatok ezzel kapcsolatban, és végül is sikerült úgy, hogy a munkalapon tudok használni feltételes formázást úgy hogy a "célkereszt" is jól működik.
Egy kis összefoglaló ha valakinek később kellene
Ezt a kódot kell a Munka1 kódlapjára
Public fmtcondis As New Collection
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim ujfmtr As FormatCondition, ujfmtc As FormatCondition, ujfmtt As FormatCondition
On Error Resume Next
If IsError(Target.Cells.Count) Then Exit Sub
On Error GoTo 0
If Target.Cells.Count <> 1 Then Exit Sub
If fmtcondis.Count > 0 Then
On Error Resume Next
For Each fmt In fmtcondis
fmt.Delete
fmtcondis.Remove 1
Next
On Error GoTo 0
End If
With Target
With .EntireRow
Set ujfmtr = .FormatConditions.Add(Type:=xlExpression, Formula1:="1")
With ujfmtr '.FormatConditions(1)
With .Borders(xlTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 5
End With
With .Borders(xlBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 5
End With
.Interior.ColorIndex = 20
.SetFirstPriority
End With
End With
fmtcondis.Add ujfmtr, "fmt1"
With .EntireColumn
Set ujfmtc = .FormatConditions.Add(Type:=xlExpression, Formula1:="1")
With ujfmtc '.FormatConditions(1)
With .Borders(xlLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 5
End With
With .Borders(xlRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 5
End With
.Interior.ColorIndex = 20
.SetFirstPriority
End With
End With
fmtcondis.Add ujfmtc, "fmt2"
Set ujfmtt = .FormatConditions.Add(Type:=xlExpression, Formula1:="1")
ujfmtt.Interior.ColorIndex = 36
ujfmtt.SetFirstPriority
fmtcondis.Add ujfmtt, "fmt3"
End With
End SubEzt pedig a ThisWorkbook -ra
Public kilepo As Boolean
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
If kilepo Then Exit Sub
Application.ScreenUpdating = False
ActiveCell.Offset(0, 1).Select
ActiveCell.Offset(0, -1).Select
Application.ScreenUpdating = True
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
If MsgBox("Valóban kilép?", vbQuestion + vbYesNo, "Bezárás") = vbNo Then
Cancel = True
Else
valasz = MsgBox("Menti a változásokat?", vbQuestion + vbYesNoCancel, "Bezárás")
If valasz = vbCancel Then Cancel = True: Exit Sub
If Munka1.fmtcondis.Count > 0 Then
For Each fmt In Munka1.fmtcondis
fmt.Delete
Munka1.fmtcondis.Remove 1
Next
End If
If valasz = vbNo Then
ThisWorkbook.Saved = True
kilepo = True
Else
kilepo = True
ThisWorkbook.Save
End If
End If
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If Munka1.fmtcondis.Count > 0 Then
For Each fmt In Munka1.fmtcondis
fmt.Delete
Munka1.fmtcondis.Remove 1
Next
End If
End Sub
Private Sub Workbook_Open()
Application.ScreenUpdating = False
ActiveCell.Offset(0, 1).Select
ActiveCell.Offset(0, -1).Select
Application.ScreenUpdating = True
End SubÍgy ez a célkereszt a kijelölt cellára a Munka1 nevű lapon működik.
Ha pedig ugyanezen a lapon feltételes formázást is kell használni akkor az itt leírtakat kell alkalmazni.
Még egyszer köszönöm Delila_1 és persze Fferi50
-
Delila_1
veterán
válasz
b3n1t0
#32365
üzenetére
A makrót modulba kell tenned.
Sorra veszi az A oszlop dátumait. Ha van azoknak megfelelő lap a füzetben, akkor annak az első üres sorába másol. Ha nincs létrehozza a lapot.
Mivel lapnévben nem szerepelhet a törtjel, helyette alsó kötőjelet ír. Az A oszlopban maradhat a törtjeles dátum, nem kell módosítanod.
Sub Kulon_Lapra()
Dim sor As Long, lapnev As String, a, hova As Long
sor = 1
Do While Cells(sor, 1) <> ""
lapnev = Cells(sor, "A")
lapnev = Left(lapnev, 2) & "_" & Mid(lapnev, 4, 2) & "_" & Right(lapnev, 2)
On Error Resume Next
Set a = Sheets(lapnev)
If Err.Number <> 0 Then
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = lapnev
Sheets(1).Activate
End If
On Error GoTo 0
hova = Application.WorksheetFunction.CountA(Sheets(lapnev).Columns(1)) + 1
Rows(sor).Copy Sheets(lapnev).Cells(hova, 1)
sor = sor + 1
Loop
End Sub -
Declare
őstag
válasz
Fferi50
#31875
üzenetére
Valami nem jo. Csak az utolso esetben csinalja azt, amit kell, az összes többiben nem.Igy nez ki ugye a kod
Sub FormatText()
Dim i As Integer
For i = 1 To Range("A" & "100").End(xlUp).Row Step 1
If Application.WorksheetFunction.CountIf(Range("H" & i & ":H" & i), "w") > 0 Then
Range("A" & i & ":H" & i).Select
Selection.Font.Name = "Calibri"
Selection.Font.FontStyle = "Italic"
Selection.Font.Underline = xlUnderlineStyleSingle
Range("E" & i).Value = Range("A" & i).Value & " " & Range("D" & i).Value
Range("E" & i).HorizontalAlignment = xlRight
Range("A" & i & ":D" & i).ClearContents
On Error Resume Next
If Range("H" & Selection.Row).Value = "w" Then Range("F" & Selection.Row).Formula = "=Sum(" & Range("F" & Selection.Row - 1).Address & ":" & Range("F" & Range("H" & Selection.Row).EntireColumn.Find(what:="p", LookIn:=xlValues, SearchDirection:=xlPrevious, lookat:=xlWhole).Row).Address & ")"
If Err <> 0 Then If Range("H" & i).Value = "w" Then Range("F" & i).Formula = "=Sum(" & Range("F" & i - 1, Cells(1, "F")).Address & ")"
On Error GoTo 0
End If
Next i
End SubFeltöltöttem egy par sorra leegyszerüsitett excelt a dropboxba, benne van ez a makro is [link] .
Ha esetleg valamikor lesz idötök/kedvetek ranezni, akkor ebben latszik, hogy hogy nez ki a nyers tabla, amin le kell futnia a makronak. Az utolso "tömbnel" jol müködik, ott jol szummaz. A többinel nem.
Ez most nem különösebben sürgös, a korabbiakkal böven kisegitettetek, ez csak majd a tovabb lepeshez lenne jo
-
bsasa1
csendes tag
válasz
Declare
#31864
üzenetére
Szia, nálam így működik:
Sub FormatText()
Dim i As Integer
For i = 1 To Range("A55").End(xlUp).Row
If Application.WorksheetFunction.CountIf(Range("H" & i), "w") > 0 Then
Range("A" & i & ":H" & i).Select
Selection.Font.Name = "Calibri"
Selection.Font.FontStyle = "Italic"
Selection.Font.Underline = xlUnderlineStyleSingle
Range("E" & i).Value = Range("A" & i).Value & " " & Range("D" & i).Value
Range("E" & i).HorizontalAlignment = xlRight
Range("A" & i & ":D" & i).ClearContents
End If
On Error Resume Next
If Range("H" & i).Value = "p" Then Range("F" & i).Formula = "=Sum(" & Range("F" & Range("H1:H" & i - 1).Find(what:="p", LookIn:=xlValues, SearchDirection:=xlPrevious, lookat:=xlWhole).Row + 1).Address & ":" & Range("F" & i - 1).Address & ")"
If Err <> 0 Then If Range("H" & i).Value = "p" Then Range("F" & i).Formula = "=Sum(" & Range("F1:F" & i - 1).Address & ")"
On Error GoTo 0
Next i
End SubDe pl ha az első sorban van a "p", vagy több van egymás után akkor azt nem tudja túl jól kezelni.
-
Declare
őstag
válasz
Fferi50
#31862
üzenetére
Tuti, most mar kiirja a szumm függvenyt, köszönöm Viszont, most kiprobaltam konkret szamokkal is es nem jo valami
Szoval ez a teljes kod:
Sub FormatText()
Dim i As Integer
For i = 1 To Range("A" & "55").End(xlUp).Row Step 1
If Application.WorksheetFunction.CountIf(Range("H" & i & ":H" & i), "w") > 0 Then
Range("A" & i & ":H" & i).Select
Selection.Font.Name = "Calibri"
Selection.Font.FontStyle = "Italic"
Selection.Font.Underline = xlUnderlineStyleSingle
Range("E" & i).Value = Range("A" & i).Value & " " & Range("D" & i).Value
Range("E" & i).HorizontalAlignment = xlRight
Range("A" & i & ":D" & i).ClearContents
On Error Resume Next
If Range("H" & Selection.Row).Value = "p" Then Range("F" & Selection.Row).Formula = "=Sum(" & Range("F" & Selection.Row - 1).Address & ":" & Range("F" & Range("H" & Selection.Row).EntireColumn.Find(what:="p", LookIn:=xlValues, SearchDirection:=xlPrevious, lookat:=xlWhole).Row).Address & ")"
If Err <> 0 Then If Range("H" & i).Value = "p" Then Range("F" & i).Value = Application.Sum(Range("F" & i - 1, Cells(1, "F")))
On Error GoTo 0
End If
Next i
End Subaz "On Error..." tol indul, amit irtal. Azzal valami gubanc van.
Szoval azt kellene csinalnia, hogy amelyik sorban megtalalta a "w" erteket a "H" oszlopban, annak a sornak az "F" cellajaba szummazza az "F" oszlop cellainak ertekeit felfele, egeszen addig, amig "p" erteket nem talal a "H" oszlopban.
Aztan megy tovabb, megint talal egy "w" erteket, formaz, szummaz felfele....ez igy blokkonkent nagyon sokszor
Vagy valahogy mashogy kellene, hogy a "p" ertekek az I oszlopban legyenek mondjuk?
Aztan lassan befejezem, mert nem akarom teljesen kisajatitani a topicot
-
Fferi50
Topikgazda
válasz
Declare
#31802
üzenetére
Szia!
Ezt a sort írd be a makróba:
If Range("H" & Selection.Row).Value = "p" Then Range("F" & Selection.Row).Value = Application.Sum(Range("F" & Selection.Row - 1, Cells(Range("H" & Selection.Row).EntireColumn.Find(what:="p", LookIn:=xlValues, SearchDirection:=xlPrevious, lookat:=xlWhole).Row, "F")))Ha a "h" feltétellel együtt kell teljesülnie, akkor az End If sor elé.
Ha csak a "p" feltételnek kell teljesülnie, akkor egy kicsit átalakítva az End If utánIf Range("H" & i).Value = "p" Then Range("F" & i).Value = Application.Sum(Range("F" & i - 1, Cells(Range("H" & i).EntireColumn.Find(what:="p", LookIn:=xlValues, SearchDirection:=xlPrevious, lookat:=xlWhole).Row, "F")))Az első p esetében hibát okozhat, hogy nincs előtte még másik p az oszlopban, ebben az esetben a hibakezelésben az első sortól kell az összeadást csinálni.
On Error Resume Next
ide jön a képlet
If Err <>0 then If Range("H" & i).Value = "p" Then Range("F" & i).Value = Application.Sum(Range("F" & i - 1, Cells(1, "F")))
On Error Goto 0Üdv.
-
Delila_1
veterán
válasz
bteebi
#31560
üzenetére
Kicsit másképp rendeztem az adatokat. Az A oszlopban vannak a hetek 21–52-ig. A heti 2 dátum a B és C oszlopban látható. A neveket a K oszlopba tettem.
A makró a heti 2 nevet a D és E oszlopba írja be. Két ellenőrző oszlopot tettem be az F, ill. az L oszlopba, a képen látszik ezeknek a képlete.A makró
Sub Beosztas()
Const also = 1: Const felso = 17
Dim napok(1 To 17), db As Long, tele As Long
Dim sor As Integer, oszlop As Integer, dolg As Integer
For sor = 2 To 33
For oszlop = 4 To 5 'D:E
Veletlen:
Randomize
dolg = Round(Rnd() * (felso - also) + also, 0)
If napok(dolg) = "X" Then GoTo Veletlen
napok(dolg) = "X"
Cells(sor, oszlop) = Cells(dolg, 11) 'K oszlop, nevek
DoEvents
db = 0
For tele = 1 To 17
If napok(tele) = "X" Then
db = db + 1
End If
Next
If db = 17 Then
For tele = 1 To 17
napok(tele) = ""
Next
db = 0
End If
Next
Next
End Sub
-
#31479
teacherhajni
újonc
Delila_1
#31478
teacherhajni
újonc
válasz
Delila_1
#31478
üzenetére
Nagyon szépen köszönöm! Ez kézzel több órás munka volt eddig
Sub Kepek()
Dim Kepneve As String, utvonal As String, sor As Long
Dim usor As Long
Dim file As Stringutvonal = "C:\Users\Public\Pictures\Sample Pictures\"
usor = Range("A" & Rows.Count).End(xlUp).RowFor sor = 1 To usor
Kepneve = Cells(sor, "A") & ".jpg"
If Cells(sor, "A") = "" Then GoTo Tovabb
file = Dir(utvonal & Kepneve)
If file = "" Then GoTo Tovabb
With ActiveSheet.Pictures.Insert(utvonal & Kepneve)
.Left = Columns(4).Left
.Top = Rows(sor).Top
.Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 120
End With
If Kepneve = "" Then GoTo Tovabb
Rows(sor).RowHeight = 130Tovabb:
Next
End Sub -
#31478
Delila_1
veterán
teacherhajni
#31477
Delila_1
veterán
válasz
teacherhajni
#31477
üzenetére
Próbáld így:
Sub Kepek()
Dim Kepneve As String, utvonal As String, sor As Long
Dim usor As Long
utvonal = "C:\Users\Public\Pictures\Sample Pictures\"
usor = Range("A" & Rows.Count).End(xlUp).Row
For sor = 1 To usor
If Cells(sor, "A") = "" Then GoTo Tovabb
Kepneve = Cells(sor, "A") & ".jpg"
With ActiveSheet.Pictures.Insert(utvonal & Kepneve)
.Left = Columns(4).Left
.Top = Rows(sor).Top
.Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 120
End With
Rows(sor).RowHeight = 130
Tovabb:
Next
End Sub -
Nowitzki
csendes tag
válasz
Declare
#31162
üzenetére
Ez hozzáírja a fájlnévhez a mentés dátumát (év, hó, nap, óra, perc).
Sub ActiveSheetExportToPdf1()
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1)) & "_Laserteileliste_" & Format(Now, "yyyymmdd_hhnn") & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End SubEz pedig hozzáad egy növekményes azonosítót a fájlnévhez ha az már létezik.
Sub ActiveSheetExportToPdf2()
cntr = ""
If Dir(ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1)) & "_Laserteileliste" & cntr & ".pdf") = "" Then GoTo xprt
If Dir(ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1)) & "_Laserteileliste" & cntr & ".pdf") <> "" Then
cntr = 1
Do Until Dir(ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1)) & "_Laserteileliste" & cntr & ".pdf") = ""
cntr = cntr + 1
Loop
End If
xprt:
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1)) & "_Laserteileliste" & cntr & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End Sub -
Delila_1
veterán
válasz
gaben86
#31138
üzenetére
Az M oszlopba írtam be soronként a megjelenítendő képek nevét, kiterjesztés nélkül. Mikor az A:G tartományban rákattintasz egy cellára, ahol az M oszlopban van képnév, a H oszlopban megjelenik a megfelelő kép.
A lapodhoz kell rendelni a makrót. Írd át az útvonalat!
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Kepneve As String, utvonal As String
If Not Intersect(Target, [A:G]) Is Nothing Then
utvonal = "C:\Adott mappa\" 'Ide az igazi útvonalat írd be!
On Error Resume Next
ActiveSheet.Shapes("Kep").Delete
Kepneve = Cells(Target.Row, "M") & ".jpg"
With ActiveSheet.Pictures.Insert(utvonal & Kepneve)
.Name = "Kep"
.Left = Columns(8).Left
.Top = ActiveCell.Top
.Height = 180
End With
On Error Goto 0
End If
End Sub -
Delila_1
veterán
válasz
Fferi50
#31032
üzenetére
Igen, ez egy másik felfogása a feladatnak. Megírtam ezt is. A futási idők különbsége csak sok sor esetén mérhető, én mindössze 20 sorral dolgoztam.
Nem tudjuk, hány oszlop van az Eredeti lapon. A makróban az A:K tartományt vettem alapul, amit két helyen kell módosítani, a csillagokkal jelzett sorokban.
Szerk.: az A:K tartományra történő hivatkozást is át lehetne állítani a makróban, de azt már nem írom meg.
Sub Kulcsok()
Dim usor As Long, usor1 As Long, lap As String, sor As Long, lapnev
With Sheets("Eredeti")
.Range("AA:AN").ClearContents
.Range("AA1") = .Range("C1")
.Range("AB1") = .Range("AA1")
.Range("A1:K1").Copy .Range("AD1") '*****
usor = .Range("C" & Rows.Count).End(xlUp).Row
.Range("C1:C" & usor).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=.Range("AA1"), Unique:=True
usor1 = .Range("AA" & Rows.Count).End(xlUp).Row
For sor = 2 To usor1
.Cells(2, "AB") = .Cells(sor, "AA")
'*****
.Range("A1:K" & usor).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("AB1:AB2"), _
CopyToRange:=.Range("AD1:AN1"), Unique:=False
lap = .Range("AB2") & ""
On Error Resume Next
Set lapnev = Sheets(lap)
If Err.Number <> 0 Then
Sheets.Add Before:=Sheets(Sheets.Count)
ActiveSheet.Name = lap
On Error GoTo 0
Else
Sheets(lap).Cells.ClearContents
End If
.Range("AD1").CurrentRegion.Copy Sheets(lap).Range("A1")
Next
End With
Beep
MsgBox "Kész van.", vbInformation
End Sub -
Delila_1
veterán
válasz
Simba86
#31027
üzenetére
Az eredeti, ömlesztett adatokat tartalmazó lapnak az Eredeti nevet adtam. A csillagokkal jelzett sorban írd át a nevét.
A makró végig megy az Eredeti lap sorain. Megnézi, van-e a sorban szereplő ÁFA-kód nevű lap. Ha nincs, létrehozza. Az aktuális sor adatait átmásolja a megfelelő lapra.
Sub Szortirozas()
Dim sor As Long, usor As Long, kod, lapnev
With Sheets("Eredeti") '*****
sor = 2
Do While .Cells(sor, "C") <> ""
kod = .Cells(sor, "C") & ""
On Error Resume Next
Set lapnev = Sheets(kod)
If Err.Number <> 0 Then
Sheets.Add Before:=Sheets(Sheets.Count)
ActiveSheet.Name = kod
.Rows(1).Copy Sheets(kod).Range("A1")
.Rows(sor).Copy Sheets(kod).Range("A2")
On Error GoTo 0
Else
usor = Application.WorksheetFunction.CountA(Sheets(kod).Columns(3)) + 1
.Rows(sor).Copy Sheets(kod).Range("A" & usor)
End If
sor = sor + 1
Loop
End With
Beep
MsgBox "Kész van.", vbInformation
End Sub -
Delila_1
veterán
A lenti makróban meg kell adnod a keresendő dátumot, és a sor számát, ahol keresel.
Ellenőrzi a bevitt értéket. Két sort megjegyzésbe tettem, azokban megadhatod, hogy nem lehet a dátum éve kisebb, mint az idei, ill. nem lehet kisebb a mai dátumnál.
Sub DatumHelye()
Dim Kelt As String, oszlop, sor As Long
sor = Application.InputBox("Melyik sorban keressünk?", "Sorszám bekérése", , , , , , 1)
Kelt = Application.InputBox("Add meg a dátumot!", "Dátum bekérése", , , , , , 2)
'Ellenőrzés
If Len(Kelt) <> 10 Then GoTo Hiba
If Mid(Kelt, 5, 1) <> "." Then GoTo Hiba
If Mid(Kelt, 8, 1) <> "." Then GoTo Hiba
If Mid(Kelt, 6, 2) > "12" Then GoTo Hiba
If Right(Kelt, 2) > "31" Then GoTo Hiba
If Not IsNumeric(Left(Kelt, 4)) Then GoTo Hiba
If Not IsNumeric(Mid(Kelt, 6, 2)) Then GoTo Hiba
If Not IsNumeric(Right(Kelt, 2)) Then GoTo Hiba
'If Left(Kelt,4)*1 < Year(Date) Then Go To Hiba
'If CDate(Kelt) *1 < Date Then GoTo Hiba
Select Case Mid(Kelt, 6, 2)
Case "02"
If Left(Kelt, 4) / 4 <> Int(Left(Kelt, 4) / 4) And Right(Kelt, 2) > 28 Then GoTo Hiba
Case "04", "06", "09", "11"
If Right(Kelt, 2) > 30 Then GoTo Hiba
End Select
If Left(Kelt, 4) / 4 = Int(Left(Kelt, 4) / 4) And Mid(Kelt, 6, 2) = "02" _
And Right(Kelt, 2) > 29 Then GoTo Hiba
'Keresés
oszlop = Application.Match(CDate(Kelt) * 1, Rows(sor), 0)
If VarType(oszlop) = vbError Then
MsgBox "Nincs " & Kelt & " dátum a " & sor & ". sorban", vbOKOnly + vbInformation
Else
MsgBox "A " & Kelt & " dátum a(z) " & sor & ". sorban, a(z) " & oszlop & ". oszlopban található.", vbOKOnly + vbInformation
End If
Exit Sub
Hiba:
MsgBox "Hibás dátum!", vbOKOnly + vbCritical
End Sub -
-
alfa20
senior tag
sziasztok!
Makróban szűrők egy oszlopra és kierőltetem a látható cellákat
Range("G2:G" & usor).SpecialCells(xlCellTypeVisible).Selectviszont ha nincs szűrési feltét, akkor hibát kapok: "nincs ilyen cella" ezt hogy tudom át ugrani?
On Error GoTo tova1-al nem sikerültOn Error GoTo tova2
ActiveSheet.Range("A1:W" & usor).AutoFilter Field:=23, Criteria1:="szures"
Range("G2:G" & usor).SpecialCells(xlCellTypeVisible).Select
Selection.Font.Bold = True
tova2: -
Szicskeee
tag
hp = InputBox("Hanyadik honap?")
ActiveSheet.PivotTables("PivotTable1").PivotFields("Honap").ClearAllFilters
On Error GoTo msg
ActiveSheet.PivotTables("PivotTable1").PivotFields("Honap").CurrentPage = hp
msg:
MsgBox ("Nem letezik ilyen honap!")Ezzel probalkoztam de sajnos a letezo honapra is azt irja, hogy nem letezik.
-
bsh
addikt
válasz
stivi1g
#29969
üzenetére
nekem nem teljesen világos: gondolom a B oszloptól az AF oszlopig január 1-től január 31-ig lennének a dátumok (csak nem látszik), de a tartalék mező csak jan.22-től van? akkor most csak jan22-jan31 közti mezőket vegye figyelembe? vagy a tartalék mezők ki lesznek bővítve? vagy nem tudom...
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
On Error GoTo xit
Set Target = Target.Cells.Item(1)
If Not Intersect(Target, Me.Range("B9:AF500")) Is Nothing Then
If Target = "tartalék" Then
x = WorksheetFunction.Match(Me.Cells(8, Target.Column), Me.Range("AI12:AR12"), 0) - 1
Me.Range("AI12:AI512").Offset(0, x).Find("") = Me.Cells(Target.Row, 1)
End If
End If
xit:
Application.EnableEvents = True
End Sub
ez a teljes(?) dátumtartományban (B-AF oszlopok) "figyel", és az AI12:AR12 cellákban lévő dátumokkal hasonlít össze, ezek persze kiterjeszthetők/lecsökkenthetők. -
#29913
Delila_1
veterán
huliganboy
#29911
Delila_1
veterán
válasz
huliganboy
#29911
üzenetére
Nem tudom, a C oszlopban meghagyandó adat szöveges, vagy szám típusú, ezért mindkettőre rákérdezek.
A makró
Sub Kigyomlal()
Dim sor As Long, usor As Long, marad, eddig As Long
marad = InputBox("Melyik adat maradjon meg a C oszlopban?")
Application.ScreenUpdating = False
usor = Range("C" & Rows.Count).End(xlUp).Row
For sor = usor To 2 Step -1
eddig = Range("C" & Rows.Count).End(xlUp).Row
If Cells(sor, "C") = marad Or Cells(sor, "C") = marad * 1 Then GoTo Tovabb
If Application.WorksheetFunction.CountIf(Range("C2:C" & eddig), Cells(sor, "C")) > 1 Then _
Rows(sor).Delete Shift:=xlUp
Tovabb:
Next
Application.ScreenUpdating = True
End Sub -
#29911
huliganboy
addikt
huliganboy
addikt
Szerintetek ez miért nem működik nekem? Egy oldalon találtam, azt hittem megoldás a problémámra.
Feladat: C oszlop második cellájától a cellákban levő értékeket vizsgálni, és ha van azonos akkor a hozzá tartozó sorokat törölni, egy kivételével!
Sub RemoveDuplicatesCells_EntireRow()
'PURPOSE: Remove the entire row of duplicate cell values within a selected cell range
'SOURCE: www.TheSpreadsheetGuru.com
Dim rng As Range
Dim x As Integer
'Optimize code execution speed
Application.ScreenUpdating = False
'Determine range to look at from user's selection
On Error GoTo InvalidSelection
Set rng = Selection
On Error GoTo 0
'Ask user which column to look at when analyzing duplicates
On Error GoTo InputCancel
x = InputBox("Which column should I look at? (Number only!)", _
"Select A Column", 1)
On Error GoTo 0
'Optimize code execution speed
Application.Calculation = xlCalculationManual
'Remove entire row if duplicate is found
rng.EntireRow.RemoveDuplicates Columns:=x
'Change calculation setting to Automatic
Application.Calculation = xlCalculationAutomatic
Exit Sub
'ERROR HANDLING
InvalidSelection:
MsgBox "You selection is not valid", vbInformation
Exit Sub
InputCancel:
End SubKöszi!
-
#29621
Delila_1
veterán
m.zmrzlina
#29610
Delila_1
veterán
válasz
m.zmrzlina
#29610
üzenetére
Amint megírtam a makrót, elszállt az internet, de most visszajött.
Sub Szetcincal()
Dim oszlop As Integer, usor As Long
Dim szoveg As String, betu As Integer
Dim szoveg1 As String, nagy As Integer
Dim ekezet As String
' Csere
With Columns("A:Z")
.Replace What:=",", Replacement:=""
.Replace What:=" ", Replacement:=""
End With
ekezet = "á,é,í,ó,ö,ő,ú,ü,ű"
For oszlop = 1 To 26 'A:Z oszlopok
Kezd:
szoveg = Cells(1, oszlop)
szoveg1 = ""
nagy = 0
For betu = 1 To Len(szoveg)
Do
If betu = 1 Then
szoveg1 = Left(szoveg, 1)
GoTo Tovabb
End If
If (Asc(Mid(szoveg, betu, 1)) > 96 And Asc(Mid(szoveg, betu, 1)) < 123 And _
betu > 1) Or InStr(ekezet, Mid(szoveg, betu, 1)) > 0 Then
szoveg1 = szoveg1 & Mid(szoveg, betu, 1)
Else
nagy = nagy + 1
usor = Cells(Rows.Count, oszlop).End(xlUp).Row + 1
Cells(usor, oszlop) = szoveg1
szoveg = Right(szoveg, Len(szoveg) - Len(szoveg1))
Cells(1, oszlop) = szoveg
GoTo Kezd
End If
Loop While nagy <> 0
Tovabb:
Next
Next
End Sub -
bsh
addikt
válasz
poffsoft
#29356
üzenetére
most ezt úgy kérdezem, hogy ekcellhez nem értek, meg nem is próbálom ki mert őőőő ezer a dolgom
![;]](//cdn.rios.hu/dl/s/v1.gif)
de ez hogyan is akar működni? bezárás előtt beleír a táblázatba, amitől az megváltozik. ilyenkor nem ajánlja fel a mentést az ekcszell? mert akkor megint ment, de ugye aftershave megint beleír, amitől megint nem tudod bezárni, goto 10, nem? -
bsh
addikt
válasz
Belnir
#29332
üzenetére
kód a ThisWorkbook-ba:
Private Sub Workbook_Open()
On Error GoTo xit
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Logfile = FSO.OpenTextFile("Z:\ez\valami\szerveren\legyen\logfile.log", 8, True)
Logfile.WriteLine (Format(Now, "YYYY.MM.DD hh:mm:ss") & " - " & Application.UserName)
Logfile.Close
Set Logfile = Nothing
Set FSO = Nothing
xit:
End Sub -
lenkei83
tag
válasz
Delila_1
#29171
üzenetére
Kérdezek inkább konkrétabban:
Itt ez a kód, ami munkalapon belül tök jól működik: írj be véletlenszerűen 12-es számot celláka, "A1"-ben összedja. Mondjuk Munka1-en.
Ami a bajom, hogy ha a szum képletet nem activesheet-re szeretném, hanem Munka2-re (de az összeadandó értékeim maradnak Munka1-en), akkor hogyan tudom megadni minden range elé, a parent.name-et? Vagyis, hogy a szum képlet hivatkozzon Munka1-reKülönálló celláknál még egyszerűbb a helyzet, de mi van akkor, ha úgy jön ki a range, hogy 3 cella van egymás alatt, aztán egy cella valahol máshol, aztán megint 4 egymás mellett máshol stb...
Sub FindAll()
Dim fnd As String, FirstFound As String
Dim FoundCell As Range, rng As Range
Dim myRange As Range, LastCell As Range
fnd = "12"
Set myRange = ActiveSheet.UsedRange
Set LastCell = myRange.Cells(myRange.Cells.Count)
Set FoundCell = myRange.Find(what:=fnd, after:=LastCell)
If Not FoundCell Is Nothing Then
FirstFound = FoundCell.Address
Else
GoTo NothingFound
End If
Set rng = FoundCell
Do Until FoundCell Is Nothing
Set FoundCell = myRange.FindNext(after:=FoundCell)
Set rng = Union(rng, FoundCell)
If FoundCell.Address = FirstFound Then Exit Do
Loop
' rng.Select
Range("A1").Formula = "=sum(" & rng.Address & ")"
Exit Sub
NothingFound:
MsgBox "Nem található a keresett érték: " & fnd
End Sub -
#29121
szatocs1981
aktív tag
Delila_1
#29119
szatocs1981
aktív tag
válasz
Delila_1
#29119
üzenetére
Igaz, akkor így:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngz As Range
On Error GoTo Ende
Application.EnableEvents = False
For Each rngz In Application.Intersect(Columns("B"), Target).Cells
rngz.Offset(0, -1).Value = Date
Next rngz
Ende:
Application.EnableEvents = True
End Sub -
bsh
addikt
válasz
kispéé
#29017
üzenetére
másik verzió:
(feltételezi, hogy egy workbookban van a két táblázat: Munka1 és Munka2)Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Select Case Target.Worksheet.Name
Case "Munka1"
If Target.Column = 1 Then
On Error Resume Next
If Not Worksheets.Item("Munka2") Is Nothing Then
On Error GoTo 0
With Worksheets.Item("Munka2")
Set X = .Range("G:G").Find(Target.Value, lookat:=xlWhole)
If Not X Is Nothing Then
Application.EnableEvents = False
Application.Goto .Cells(X.Row, X.Column)
Application.EnableEvents = True
End If
End With
End If
On Error GoTo 0
End If
Case "Munka2"
If Target.Column = 7 Then
On Error Resume Next
If Not Worksheets.Item("Munka1") Is Nothing Then
On Error GoTo 0
With Worksheets.Item("Munka1")
Set X = .Range("A:A").Find(Target.Value, lookat:=xlWhole)
If Not X Is Nothing Then
Application.EnableEvents = False
Application.Goto .Cells(X.Row, X.Column)
Application.EnableEvents = True
End If
End With
End If
On Error GoTo 0
End If
End Select
End Sub -
bsh
addikt
-
Delila_1
veterán
Erre a kódrészletre többször kerül sor a leírásod szerint.
Mikor első esetben hibára fut, a hibakódot megjegyzi. Ha az On Error Resume Next-tel át tudtál lépni a hibán, a művelet elvégzése után le kell nulláznod a hibakódot, hogy a következő futtatáskor ne ezzel a hibával induljon. Nem tudom, hova érdemes beírni a nullázást, legegyszerűbb, ha már eleve 0 hibakóddal indítod a programrészt az On Error Resume Next sor fölött az On Error Goto 0 sorral.
-
Delila_1
veterán
válasz
Mittu88
#28305
üzenetére
Az On Error Resume Next hibát generál, ha nem tudja megnyitni a következő sorban a fájlodat.
A megnyitási hiba kódja az 1004. Mikor bejön ez a hibakód, felteszi a kérdést
valasz = MsgBox("Újrahívás", vbYesNo + vbExclamation, "Új próbálkozás")
Igen válasz esetén kilép a Sub-ból, Nem-nél az Ujra címkéhez ugrik, ahol megszüntetjük a hibakódot az
On Error GoTo 0 sorral, másképp hibát jelez akkor is, ha most már meg tudja nyitni a fájlt.
Ez a lenullázó sor tulajdonképpen a 2. próbálkozástól érdekes, első esetben 0 a hibakód. -
-
Mittu88
senior tag
válasz
Delila_1
#28261
üzenetére
Nem bírtam ki, bent maradtam túlórában kipróbálni.
Ennyit csináltam:On Error Goto 0
fnev = ....
Hiba:
Set wb1 = Workbooks.Open(Filename:=fnev)
If VarType(wb1) = vbError Then
MsgBox "Az adatbázis pillanatnyilag használatban van, OK-ra kattintva újra próbálkozom a megnyitásával.", vbOKOnly, "Hiba!"
GoTo Hiba:
End IfÉs ugyanúgy hibát dob. Mondjuk nem az adatfájlt nyitottam meg, hanem az asztalra másoltam és a másolatot nyitottam meg (de fájlnév egyezőség miatt ilyenkor is hibára fut, most meg ugye ez volt a cél).
Szerk.: annyit próbáltam még, hogy átírtam On Error Resume Next-re, akkor feldobja a hibaüzenetet, de nem próbálkozik újból az Ok gombra kattintva.
-
Delila_1
veterán
válasz
Mittu88
#28245
üzenetére
Ez a makró akkor fut hibára, ha az inputboxban olyan számot kap, ami nem szerepel az A oszlopban.
Nyilván át tudod alakítani a saját célodra.Sub hiba()
Dim lel, szam As Integer
Innen:
On Error GoTo 0
szam = Application.InputBox("Kérem az egész számot", "Szám bekérése", , , , , , 1)
lel = Application.Match(szam, Columns(1), 0)
If VarType(lel) = vbError Then
MsgBox "Újra!", vbExclamation
GoTo Innen
End If
MsgBox "A makró többi része"
End Sub -
Delila_1
veterán
válasz
Polllen
#27637
üzenetére
Nem túl bonyolult.
A makró elején töröltethettem volna az első lapon kívül a többit, hogy "tiszta lappal" kezdjünk, de nem ismerem a füzeted felépítését. Lehet, hogy vannak benne nem törölhető lapok.A makró az első lap sorain megy végig. Mikor a sorban lévő szállítólevél nevével egyező lap van a füzetben, az első üres sorába bemásolja az aktuális sort. Ha nincs olyan lap, akkor a füzet végén létrehozza, átmásolja a címsort az első lapról, majd alá az aktuális sort.
Sub Szall_Lev()
Dim sor As Long, usor As Long, usorIde As Long, nev
Dim WS As Worksheet, WSIde As Worksheet
Application.ScreenUpdating = False
Set WS = Sheets(1)
WS.Select
usor = Range("A" & Rows.Count).End(xlUp).Row
For sor = 2 To usor
On Error Resume Next
Set nev = Sheets(Cells(sor, "A") & "")
If Err.Number <> 0 Then
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = WS.Cells(sor, "A")
WS.Rows(1).Copy ActiveSheet.Range("A1")
WS.Select
End If
On Error GoTo 0
Set WSIde = Sheets(WS.Cells(sor, "A") & "")
usorIde = WSIde.Range("A" & Rows.Count).End(xlUp).Row + 1
Rows(sor).Copy WSIde.Range("A" & usorIde)
Next
Sheets(1).Activate
Application.ScreenUpdating = True
MsgBox "Kész", vbInformation
End Sub -
Delila_1
veterán
válasz
RedHarlow
#27630
üzenetére
Így már rendben.
A füzetben az első lap az, amin ömlesztve vannak az adatok. Ezt követi a két lap, ahova másolni kell.
A makróban két helyen szerepel a
Sheets(Array("Munka2", "Munka3")).Select
sor, ezekben írd át a Munka2 és Munka3 lapneveket a füzetedben lévő 2. és 3. lap nevére.Szerk.: persze az X1–X4 és Y1–Y6 adatokat is írd át!
Sub SzetCincal()
Dim nev As String, sor As Long, usor As Long, usorIde As Long
Dim WS As Worksheet, WSIde As Worksheet, lap As Integer
Set WS = Sheets(1)
'Előző adatok törlése
Sheets(Array("Munka2", "Munka3")).Select
Cells.Select
Selection.ClearContents
'Címsor a 2 lapra
WS.Rows("1:1").Copy
Sheets(Array("Munka2", "Munka3")).Select
Range("A1").PasteSpecial xlPasteValues
'Szortírozás
WS.Select
usor = Range("A" & Rows.Count).End(xlUp).Row
For sor = 2 To usor
nev = Cells(sor, 6)
Select Case nev
Case ""
If Cells(sor, 5) = "Y1" Or Cells(sor, 5) = "Y2" Or _
Cells(sor, 5) = "Y3" Then lap = 2
If Cells(sor, 5) = "Y4" Or Cells(sor, 5) = "Y5" Or _
Cells(sor, 5) = "Y6" Then lap = 3
Case "X1", "X2"
lap = 2
Case "X3", "X4"
lap = 3
Case Else
GoTo Tovabb
End Select
Set WSIde = Sheets(lap)
usorIde = WSIde.Range("A" & Rows.Count).End(xlUp).Row + 1
Rows(sor).Copy WSIde.Range("A" & usorIde)
Tovabb:
Next
End Sub -
Delila_1
veterán
válasz
Carasc0
#27604
üzenetére
Csak írd be az A oszlopba az adatokat. Ha nem kerek számot adna az adatok darabszámának a gyöke, hibajelzést kapsz.
Hibátlan darabszámnál kiírja a "kevert" mátrixot a D1 cellától kezdődően. 9; 16; 25; és 36 adatra kipróbáltam, nem kell módosítanod semmit. Illetve ha nem tetszik, hogy D1-be kezd írni, akkor a
sor = 1: oszlop = 4 sorban a 4-et írd át a kedvenc oszlopod sorszámára.Sub Kever()
Dim usor As Integer, gyok As Integer, CV As Range
Dim sor As Integer, oszlop As Integer
Application.ScreenUpdating = False
usor = Range("A" & Rows.Count).End(xlUp).Row
On Error GoTo Vege
gyok = Application.WorksheetFunction.ImSqrt(usor)
Range("A1:A" & usor).Copy Range("B1")
Range("C1:C" & usor) = "=rand()"
Range("C1:C" & usor).Copy
Range("C1").PasteSpecial xlPasteValues
ActiveWorkbook.Worksheets("Munka1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Munka1").Sort.SortFields.Add Key:=Range("C1:C" & usor), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Munka1").Sort
.SetRange Range("B1:C" & usor)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
sor = 1: oszlop = 4
For Each CV In Range("B1:B" & usor)
If sor > gyok Then
sor = 1
oszlop = oszlop + 1
End If
CV.Copy Cells(sor, oszlop)
sor = sor + 1
Next
Range("B1:C" & usor).ClearContents
Range("D1").Select
Application.ScreenUpdating = True
Exit Sub
Vege:
MsgBox "Nem adnak mátrixot az adatok", vbInformation
Application.ScreenUpdating = True
End Sub -
Delila_1
veterán
válasz
Melack
#27477
üzenetére
A próbánál a füzet utolsó lapját elneveztem Gyűjtés-nek. A MitKeres változóba tettem be a keresendő adatot.
A makró az elsőtől az utolsó előtti lapig megkeresi a MitKeres értéket, és a találat sorát a Gyűjtés lap első üres sorába bemásolja.Sub Kigyujt()
Dim lap As Integer, WSG As Worksheet, Hol, usor As Long
Application.ScreenUpdating = False
Const MitKeres = "Máté" 'Itt add meg a keresendő értéket
Set WSG = Sheets("Gyűjtés")
WSG.Rows("2:2000") = ""
For lap = 1 To Worksheets.Count - 1
Sheets(lap).Select
Set Hol = Cells.Find(MitKeres, LookIn:=xlValues, lookat:=xlWhole)
If Hol Is Nothing Then
GoTo Tovabb
Else
usor = WSG.Range("A" & Rows.Count).End(xlUp).Row + 1
Rows(Hol.Row).Copy WSG.Range("A" & usor)
End If
Tovabb:
On Error GoTo 0
Next
WSG.Select
Application.ScreenUpdating = True
End SubEz laponként az első találatot teszi ki. Ha több kell, valaki biztosan segít, most el kell mennem.
-
sedyke
tag
válasz
Delila_1
#27392
üzenetére
Eleg nagy munkafuzet, 17MB, 33 munkalappal.
Eddig az osszesitom a masodik volt, de atraktam az elso helyre. A ket munkalap, amit ki szeretnek hagyni a keresesbol, a 29. es 33. (leszamoltam 3x).A leirasod alapjan igy egeszitettem ki. Fut a makro, a problema annyi, hogy megis minden egyes sorba beirja, hogy az adott termek hasznalatban van, pedig ha kihagyna a ket szoban forgo lapot, akkor nem lenne.
Sub Van_e()
Dim talal, sor As Long, usor As Long, nev, lap As Integer
Dim WS As WorksheetSet WS = Sheets(1)
usor = WS.Range("A" & Rows.Count).End(xlUp).Row
For sor = 4 To usor
nev = WS.Cells(sor, "A")For lap = 1 To Sheets.Count
If lap = 29 Or lap = 33 Then Exit For
Sheets(lap).Select
Set talal = Cells.Find(nev, LookIn:=xlValues, lookat:=xlWhole)
If talal Is Nothing Then
GoTo Tovabb
Else
WS.Cells(sor, "W") = "in use"
Exit For
End If
Tovabb:
Next
Next
End Sub -
Delila_1
veterán
válasz
sedyke
#27360
üzenetére
Azt hiszem, ne pontosan írtad le a feladatot. Megírtam a makrót a következő felállásra:
A füzet első lapja az összesítés, ahol a termékek az A oszlopban vannak. Azt az esetet vettem, hogy nincsenek üres sorok, és az első a címsor.
Az összes többi lapon keresünk.A makró megjegyzi az összesítő lap A2-es cellájának az értékét, majd sorban ellenőrzi a többi lapon, hogy van-e ilyen nevű termék. Ha valamelyiken talál, akkor az összesítő lap W2 cellájába beírja a kért szöveget.
Következik az A3-as cella vizsgálata, majd így tovább az utolsó sorig.Sub Van_e()
Dim talal, sor As Long, usor As Long, nev, lap As Integer
Dim WS As Worksheet
Set WS = Sheets(1)
usor = WS.Range("A" & Rows.Count).End(xlUp).Row
For sor = 2 To usor
nev = WS.Cells(sor, "A")
For lap = 2 To Sheets.Count
Sheets(lap).Select
Set talal = Cells.Find(nev, LookIn:=xlValues, lookat:=xlWhole)
If talal Is Nothing Then
GoTo Tovabb
Else
WS.Cells(sor, "W") = "in user"
Exit For
End If
Tovabb:
Next
Next
End Sub -
#27145
Delila_1
veterán
scott_free
#27144
Delila_1
veterán
válasz
scott_free
#27144
üzenetére
... van egy "Emberek" nevű táblázatom egy lapon.
Ezt úgy tettem a makróba, hogy az Emberek lapon vettem fel egy táblázatot, ahol az A oszlopban vannak a nevek, B-ben a címek, C-ben a telefonok.A "lekérdezős" lap A1 cellájába tettem az érvényesítést, a megjegyzés a mellette lévő B1 cellába kerül. Ehhez a laphoz rendeltem az eseményvezérelt makrót.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then Keres Target.Value
End SubMivel az eseményvezérlés csak a saját lapján tud dolgozni, egy modulba írt másik makró végzi a keresést.
Sub Keres(nev)
Dim sor As Long, Cim As String, Tel As String
With Sheets("Emberek")
sor = Application.Match(nev, .Columns(1), 0)
Cim = .Cells(sor, "B")
Tel = .Cells(sor, "C")
End With
On Error Resume Next
Cells(1, "B").AddComment
Cells(1, "B").Comment.Text Text:="Cím: " & Cim & vbLf & "Tel: " & Tel
On Error GoTo 0
End SubAz On Error Resume Next sor arra szolgál, hogy ha már van megjegyzés a B1 cellához fűzve, ne fusson hibára a makró. Ennek a feloldása az On Error GoTo 0 sor.
-
zhari
csendes tag
válasz
Fferi50
#26648
üzenetére
Köszi.
Ezt találtam még a neten de nem akar működni a szerző és az tulaj bejegyzés kinyerése. Meg tudnátok nézni h mi baja lehet?
Előre is köszi
Option Explicit
Public x()
Public i As Long
Public objShell, objFolder, objFolderItem
Public FSO, oFolder, Fil
Sub MainExtractData()
Dim NewSht As Worksheet
Dim MainFolderName As String
Dim TimeLimit As Long, StartTime As Double
ReDim x(1 To 65536, 1 To 11)
Set objShell = CreateObject("Shell.Application")
TimeLimit = Application.InputBox("Please enter the maximum time that you wish this code to run for in minutes" & vbNewLine & vbNewLine & _
"Leave this at zero for unlimited runtime", "Time Check box", 0)
StartTime = Timer
Application.ScreenUpdating = False
MainFolderName = BrowseForFolder()
Set NewSht = ThisWorkbook.Sheets.Add
x(1, 1) = "Path"
x(1, 2) = "File Name"
x(1, 3) = "Last Accessed"
x(1, 4) = "Last Modified"
x(1, 5) = "Created"
x(1, 6) = "Type"
x(1, 7) = "Size"
x(1, 8) = "Owner"
x(1, 9) = "Author"
x(1, 10) = "Title"
x(1, 11) = "Comments"
i = 1
Set FSO = CreateObject("scripting.FileSystemObject")
Set oFolder = FSO.GetFolder(MainFolderName)
'error handling to stop the obscure error that occurs at time when retrieving DateLastAccessed
On Error Resume Next
For Each Fil In oFolder.Files
Set objFolder = objShell.Namespace(oFolder.Path)
Set objFolderItem = objFolder.ParseName(Fil.Name)
i = i + 1
If i Mod 20 = 0 And TimeLimit <> 0 And Timer > (TimeLimit * 60 + StartTime) Then
GoTo FastExit
End If
If i Mod 50 = 0 Then
Application.StatusBar = "Processing File " & i
DoEvents
End If
x(i, 1) = oFolder.Path
x(i, 2) = Fil.Name
x(i, 3) = Fil.DateLastAccessed
x(i, 4) = Fil.DateLastModified
x(i, 5) = Fil.DateCreated
x(i, 6) = Fil.Type
x(i, 7) = Fil.Size
x(i, 8) = objFolder.GetDetailsOf(objFolderItem, 8)
x(i, 9) = objFolder.GetDetailsOf(objFolderItem, 9)
x(i, 10) = objFolder.GetDetailsOf(objFolderItem, 10)
x(i, 11) = objFolder.GetDetailsOf(objFolderItem, 14)
Next
'Get subdirectories
If TimeLimit = 0 Then
Call RecursiveFolder(oFolder, 0)
Else
If Timer < (TimeLimit * 60 + StartTime) Then Call RecursiveFolder(oFolder, TimeLimit * 60 + StartTime)
End If
FastExit:
Range("A:K") = x
If i < 65535 Then Range(Cells(i + 1, "A"), Cells(65536, "A")).EntireRow.Delete
Range("A:K").WrapText = False
Range("A:K").EntireColumn.AutoFit
Range("1:1").Font.Bold = True
Rows("2:2").Select
ActiveWindow.FreezePanes = True
Range("a1").Activate
Set FSO = Nothing
Set objShell = Nothing
Set oFolder = Nothing
Set objFolder = Nothing
Set objFolderItem = Nothing
Set Fil = Nothing
Application.StatusBar = ""
Application.ScreenUpdating = True
End Sub
Sub RecursiveFolder(xFolder, TimeTest As Long)
Dim SubFld
For Each SubFld In xFolder.Subfolders
Set oFolder = FSO.GetFolder(SubFld)
Set objFolder = objShell.Namespace(SubFld.Path)
For Each Fil In SubFld.Files
Set objFolder = objShell.Namespace(oFolder.Path)
'Problem with objFolder at times
If Not objFolder Is Nothing Then
Set objFolderItem = objFolder.ParseName(Fil.Name)
i = i + 1
If i Mod 20 = 0 And TimeTest <> 0 And Timer > TimeTest Then
Exit Sub
End If
If i Mod 50 = 0 Then
Application.StatusBar = "Processing File " & i
DoEvents
End If
x(i, 1) = SubFld.Path
x(i, 2) = Fil.Name
x(i, 3) = Fil.DateLastAccessed
x(i, 4) = Fil.DateLastModified
x(i, 5) = Fil.DateCreated
x(i, 6) = Fil.Type
x(i, 7) = Fil.Size
x(i, 8) = objFolder.GetDetailsOf(objFolderItem, 8)
x(i, 9) = objFolder.GetDetailsOf(objFolderItem, 9)
x(i, 10) = objFolder.GetDetailsOf(objFolderItem, 10)
x(i, 11) = objFolder.GetDetailsOf(objFolderItem, 14)
Debug.Print x(i, 1), x(i, 2), x(i, 11)
Else
Debug.Print Fil.Path & " " & Fil.Name
End If
Next
Call RecursiveFolder(SubFld, TimeTest)
Next
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level
Dim ShellApp As Object
'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
'Destroy the Shell Application
Set ShellApp = Nothing
'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function -
Delila_1
veterán
Most tetszőleges név, és tetszőleges terület esetén is elkészíti a beosztást. Nincs benne viszont, hogy minden terület legalább 1× szerepeljen. Nem minden esetben van megfelelő megoldás, pl. ha sok az eszkimó (ember), és kevés a fóka (terület).
Sub Terulet()
Dim sor As Integer, oszlop As Integer, vel As Integer, i As Integer, soruj As Integer
Dim NevUsor As Long, TerUsor As Long
Dim tomb()
NevUsor = Range("A" & Rows.Count).End(xlUp).Row
TerUsor = Range("G" & Rows.Count).End(xlUp).Row
ReDim tomb(1 To TerUsor)
Application.ScreenUpdating = False
Range("B4:E" & NevUsor) = ""
For sor = 4 To NevUsor
UjSor:
For oszlop = 2 To 5
UJRA:
Randomize
vel = Round(Rnd() * (TerUsor - 3) + 3, 0) '
If tomb(vel) > 0 Then GoTo UJRA ' Ha volt már a sorszám, akkor újra generál
tomb(vel) = 1
Next
oszlop = 2
For i = 1 To TerUsor 'Beírja a területet, lenullázza a tömböt
If tomb(i) = 1 Then
Cells(sor, oszlop) = Cells(i, "G")
oszlop = oszlop + 1
End If
tomb(i) = 0
Next i
For soruj = 3 To TerUsor 'Van-e 3× a terület?
If Application.CountIf(Range("$B$4:$E" & NevUsor), Range("G" & soruj)) > 3 Then
Range("B" & sor & ":E" & sor) = ""
For i = 1 To TerUsor
tomb(i) = 0
Next
GoTo UjSor
Exit For
End If
Next
Next
Application.ScreenUpdating = True
End Sub -
Delila_1
veterán
A makró összeállítja a területek kiosztását.
Sub Terulet()
Dim sor As Integer, oszlop As Integer, vel As Integer, i As Integer, soruj As Integer
Dim tomb(1 To 36) As Integer
Application.ScreenUpdating = False
Range("B4:E23") = ""
For sor = 4 To 23
UjSor:
For oszlop = 2 To 5
UJRA:
Randomize
vel = Round(Rnd() * 33 + 3, 0) '3 és 36 közötti véletlenszámot ad
If tomb(vel) > 0 Then GoTo UJRA ' Ha volt már a sorszám, akkor újra generál
tomb(vel) = 1
Next
oszlop = 2
For i = 1 To 36 'Beírja a területet, lenullázza a tömböt
If tomb(i) = 1 Then
Cells(sor, oszlop) = Cells(i, "G")
oszlop = oszlop + 1
End If
tomb(i) = 0
Next i
For soruj = 3 To 36 'Van-e 3× a terület?
If Application.CountIf(Range("$B$4:$E$23"), Range("G" & soruj)) > 3 Then
Range("B" & sor & ":E" & sor) = ""
For i = 1 To 36
tomb(i) = 0
Next
GoTo UjSor
Exit For
End If
Next
Next
Application.ScreenUpdating = True
End Sub -
Louro
őstag
válasz
Fferi50
#26183
üzenetére
Kreáltam magamnak egy feladatot és megnéztem ezt a megnyitásmentes megoldást és nekem az a baj, hogy ahhoz, hogy befrissüljön felugrik egy párbeszédablak, hogy tallózzam be a forrást. Az oké, hogy ha Esc-elem, akkor frissül, de nálam lehet a bibi?
Kódrészlet.
WB_Source_file = "D:\VB_Test\" & Year(Now - 30) & "\" & actual_month & "\" & code & ".xlsx"
Filename = Dir(WB_Source_file)
If Filename = "" Then
GoTo Nem_létezik_a_forrása
Else
For k = 1 To 3
Sheets("Összesített_eredmény").Cells(j, 3 + actual_month).Formula = _
"=HAHIBA('[" & Filename & "]TOTAL'!V29,""-"")"
Sheets("Kommunikáció").Cells(j, 3 + actual_month).Formula = _
"=HAHIBA('[" & Filename & "]TOTAL'!V10,""-"")"
Sheets("Mozgás").Cells(j, 3 + actual_month).Formula = _
"=HAHIBA('[" & Filename & "]TOTAL'!V18,""-"")"Rosszul hivatkozom be a másik munkafüzetet?
@26199: Köszi. Pont a hétvégén futottam bele ebbe a "másolás a célba" esetbe. Csak még nem gyakoroltam be, így ezért nem alkalmazom.
-
bara17
tag
Sziasztok!
A feladatom a következő:
Van egy sablon e-mail szöveg, amiben vannak bizonyos változók (szerződésszám, összeg, e-mail, ügyfélnév), melyek egy excel táblázatban vannak. A cél az lenne, hogy olyan makró kerüljön megírásra, mely a sablonszöveget küldje el mindegyik ügyfél számára az ügyfélhez tartozó változókkal. Alapból úgy képzeltem el, hogy a sablon szöveget átmásoltam a forrás excel másik munkalapjára és ide kerülnek bele a változók is cellákba, és innen gondoltam kiküldeni.
Az alábbi makróval (nyílván for ciklusokkal kiegészülne) kezdtem neki és az a kérdésem, hogy hogy tudnám az e-mail szövegébe beilleszteni az A1
52 (itt van a sablonszöveg) cellákat úgy, hogy a nyílván megmaradjon a formátuma is A152 tartománynak. (Ha crtl+c +crtl v-vel beillsztem a tartományt akkor normálisan illeszti be a szöveget az outlookba.)sub sablon e-mail()
Dim datumakt As Date
datumakt = Format(Date, "yyyy-mm-dd")
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next'parameterek
With OutMail
.To = Cells(26, 9) 'példa e-mail címzett
.CC = ""
.BCC = ""
.Subject = " Teszt " & datumakt & " " Aktuális dátum a levél tárgyában
.Body = "" 'e-mail szöveg.Send
End With
On Error GoTo 0Set OutMail = Nothing
Set OutApp = NothingEnd Sub
Lehet, (sőt tuti) hogy jobb megoldás is van.
Köszönöm a segítséget!
-
Delila_1
veterán
válasz
grondby
#25611
üzenetére
A lapodhoz rendelve a lenti makrót automatikus lesz a H oszlop bővítése, mikor új adatot viszel fel a B oszlopba.
A füzetedet makróbarátként kell mentened.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sor As Integer
If Target.Column = 2 Then
On Error GoTo Uj
sor = Application.Match(Target, Range("H:H"), 0)
End If
Exit Sub
Uj:
Range("H" & Application.WorksheetFunction.CountA(Columns(8)) + 1) = Target
End Sub -
Fferi50
Topikgazda
válasz
pirit28
#25559
üzenetére
Szia!
Arra tudok gondolni, hogy nem létezik a FilePathL nevű fájl és mivel a hibakezelést visszaadtad a VBA-nak ezért hibával le fog állni.
Az On Error Goto 0 sort szerintem az End If után kell beletenni.
Így a második "nyitási kísérlet után" is meg tudod nézni, hogy sikerült-e a hozzárendelés és le tudod kezelni programból a hibát.If GetFile is Nothing Then
Set GetFile=.....
If GetFile is Nothing Then
ide írhatod, hogy mi legyen ha ez sincs meg
End If
End If
On Error Goto 0Üdv.
-
alfa20
senior tag
Sziasztok,
Van egy makróm, ami egy inputbox-ból kéri be mit szeretne az illető, az a bajom, hogy ha a "Cancel"-re nyomnak, akkor azt is rossz válasznak veszi, hogy még is ki tudjanak lépni, nem túl elegáns modón, de ha a rossz válaszok elérik a 2-őt akkor kilép a programból.
Be lehet szúrni egy parancsot amivel a "cancel"-re kilép?
Sub leosztás()
Dim usor As Long, usor2 As Long, usor3 As Long, usor4 As Long
Dim uszlp As Integer, RvA As String, regi As String, ujful As String
Dim RV As Byte
RV = 0
10
If RV = 2 Then Exit Sub
RvA = InputBox("Áttárolást vagy Rendelés szeretnél leosztani?" & vbCrLf & "(A/R)", "Válassz leosztást!")
If RvA = "a" Or RvA = "A" Or RvA = "r" Or RvA = "R" Then
GoTo 20
Else
MsgBox ("Rossz válasz!")
RV = RV + 1
GoTo 10
End If
20
Application.ScreenUpdating = False
....
End Sub() -
Delila_1
veterán
válasz
KERO_SAN
#25105
üzenetére
Két makró kell hozzá. Az első figyeli a 18. oszlop kitöltését, majd indítja a másikat, ami a másolást végzi el. A laphoz rendeléshez, és a modulba tevéshez sok leírás van itt a fórumon.
Nem kell előre elkészíteni a 10 lapot, a makrók létrehozzák "1"-től "10"-ig névvel.Az alap táblázatot tartalmazó laphoz rendeld:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim LapNev As String
If IsEmpty(Target) Then Exit Sub
If Target.Column = 18 Then
LapNev = Cells(Target.Row, 1)
Masolas Target.Row, LapNev
End If
End SubModulba helyezd:
Sub Masolas(sor, LapNev)
Dim a As Object, usor As Long
Dim ElsoLap As Worksheet
Set ElsoLap = Worksheets(ActiveSheet.Name)
On Error Resume Next
Set a = Sheets(LapNev)
If Err.Number <> 0 Then
Worksheets.Add.Name = LapNev
ElsoLap.Rows(1).Copy Sheets(LapNev).Range("A1")
End If
On Error GoTo 0
usor = Sheets(LapNev).Range("A" & Rows.Count).End(xlUp).Row + 1
ElsoLap.Rows(sor).Copy Sheets(LapNev).Range("A" & usor)
ElsoLap.Move Before:=Sheets(1)
End Sub -
Fferi50
Topikgazda
válasz
MC Pite
#24535
üzenetére
Szia!
Akkor van ilyen hibaüzenet, ha az adott tartományban nem talál üres cellát. Ne feledd, attól, hogy nem látsz a cellában semmit, még lehet benne "információ" (pl. olyan képlet, aminek az eredménye üres string,stb.).
Ezt hibakezeléssel lehet makróban "kivédeni".
Pl.
on error resume next
set rngures=valami.columns("B").specialcells(xlcelltypeblanks)
if error="Nincs ilyen cella" then msgbox "Nincs üres cella"
on error goto 0Üdv.
-
Mittu88
senior tag
válasz
Fferi50
#24443
üzenetére
Szia Fferi!
String mindkét változó, annál nincs gond (ugyan a nevében raktarszam, de string az is).
Amúgy azért kell errorhandler, mert több parancs is van ott, csak feleslegesnek tartottam leírni.
A probléma az volt, hogy a GoTo hibautan helyett Resume hibautan kellett.Köszönöm szépen a segítséget, hatttalmas riszpekt
-
Fferi50
Topikgazda
válasz
Mittu88
#24442
üzenetére
Szia!
A hibautan cimke szerintem felesleges.
On Error GoTo hibavan
For sorszam = 2 To osszsorszam
Sheets(masodikadatbazis).Select
raktarszam = Cells(sorszam, 2).Value
munkalapnev = Application.WorksheetFunction.VLookup(raktarszam, Sheets("Raktárak").Range("$M$2:$N$90"), 2, False)
raktarszam = munkalapnev
...
Next
hibavan:
sorszam = sorszam + 1
resume nextNem világos, hogy a munkalapnev változód milyen típusúnak van deklarálva. Ha variant akkor nem okoz futási idejű hibát, viszont az értéke hibaérték lesz és azt kell megvizsgálni
if not iserror(munkalapnev) then raktarszam=munkalapnevViszont megoldható másképp is, ha a munkalapnev nem variant tipusu:
On Error Resume Next
For sorszam = 2 To osszsorszam
Sheets(masodikadatbazis).Select
raktarszam = Cells(sorszam, 2).Value
munkalapnev = Application.WorksheetFunction.VLookup(raktarszam, Sheets("Raktárak").Range("$M$2:$N$90"), 2, False)
if err= 0 then raktarszam = munkalapnev else sorszam=sorszam+1
...
NextÜdv.
-
Mittu88
senior tag
sziasztok!
Ebben segítsetek légyszi. A gondom, hogy az alábbi programkód után egyszer ugyan visszaugrik a hibaután: labelhez, de ha még egyszer hibát tapasztal, kifagy a program. Amúgy a munkalapnev változónak való értékadás után akad ki, mert sok esetben #HIÁNYZIK hibát dobna az fkeres függvény. Sajnos azt nem tudom kivédeni.
On Error GoTo hibavan
For sorszam = 2 To osszsorszam
hibautan:
Sheets(masodikadatbazis).Select
raktarszam = Cells(sorszam, 2).Value
munkalapnev = Application.WorksheetFunction.VLookup(raktarszam, Sheets("Raktárak").Range("$M$2:$N$90"), 2, False)
raktarszam = munkalapnev
...
Nexthibavan:
sorszam = sorszam + 1
GoTo hibautanHogy tudom megoldani, hogy az összes hiba esetén a hibavan:-ra ugorjon és ne akadjon ki?
-
róland
veterán
Ugyan nem Excel, de adott az alábbi makró:
sub Adatrogzites
rem ----------------------------------------------------------------------
rem define variables
dim document as object
dim dispatcher as object
rem ----------------------------------------------------------------------
rem get access to the document
document = ThisComponent.CurrentController.Frame
dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
rem ----------------------------------------------------------------------
dim args1(0) as new com.sun.star.beans.PropertyValue
args1(0).Name = "ToPoint"
args1(0).Value = "$B$2"
dispatcher.executeDispatch(document, ".uno:GoToCell", "", 0, args1())
rem ----------------------------------------------------------------------
dim args2(0) as new com.sun.star.beans.PropertyValue
args2(0).Name = "ToPoint"
args2(0).Value = "$B$2:$M$2"
dispatcher.executeDispatch(document, ".uno:GoToCell", "", 0, args2())
rem ----------------------------------------------------------------------
dispatcher.executeDispatch(document, ".uno:Copy", "", 0, Array())
rem ----------------------------------------------------------------------
dim args4(0) as new com.sun.star.beans.PropertyValue
args4(0).Name = "Nr"
args4(0).Value = 2
dispatcher.executeDispatch(document, ".uno:JumpToTable", "", 0, args4())
rem ----------------------------------------------------------------------
dim args5(0) as new com.sun.star.beans.PropertyValue
args5(0).Name = "ToPoint"
args5(0).Value = "$B$290"
dispatcher.executeDispatch(document, ".uno:GoToCell", "", 0, args5())
rem ----------------------------------------------------------------------
dispatcher.executeDispatch(document, ".uno:Paste", "", 0, Array())
end subA lényege, hogy egy berögzített adatsort átmásolna (kijelölés-másolás-beillesztés módszerrel) egy táblázat megfelelő sorába.
Ezt szeretném módosítani oly módon, hogy az adott dátumnak megfelelő sorba szúrja be az adatokat. (A dátumnak megfelelő sor kiszámított sorszámát az eredeti munkalap egyik (jelen esetben A3) mezője tartalmazza.Úgy néztem, hogy ebben a részben határozza meg, hogy hová is kell beszúrni:
rem ----------------------------------------------------------------------
dim args5(0) as new com.sun.star.beans.PropertyValue
args5(0).Name = "ToPoint"
args5(0).Value = "$B$290"
dispatcher.executeDispatch(document, ".uno:GoToCell", "", 0, args5())Azaz ezt szeretném úgy módosítani, hogy $B$290 érték helyett a mindenkori kívánt cellába illessze be az adatokat.
Hogy lehet ezt megoldani?
-
Fferi50
Topikgazda
válasz
Delila_1
#23738
üzenetére
Szia!
Félreértettél, nem azt írtam, hogy nincs hibakezelés a makródban - természetesen láttam, hogy ott van az on error goto tovabb és a tovabb cimke - , sőt, még azt sem írtam, hogy nem jó a ws.match, hanem azt, hogy app.match esetén nem kell külön hibakezelést beépíteni a makróba.
Üdv.
Idézet a 23730-ból:
"A worksheetfunction.match helyett célszerűbb az application.match függvényt alkalmazni, (ezt én is egy másik topicban tanultam), mivel így más módon kell a hibakezeléssel foglalkozni." -
Fferi50
Topikgazda
válasz
Delila_1
#23724
üzenetére
Szia!
Néhány apró észrevétel:
" Cells(sor + 1, oszlop).Select
usor = Selection.End(xlDown).Row
"A select teljesen felesleges, egyszerűen usor=cells(sor+1,oszlop).end(xldown).row elég.
A worksheetfunction.match helyett célszerűbb az application.match függvényt alkalmazni, (ezt én is egy másik topicban tanultam), mivel így más módon kell a hibakezeléssel foglalkozni.
A ws.match hibát generál, ha nem találja a keresett értéket, az app.match hibaértékkel tér vissza, amit változóban vagy függvényben is "elkaphatsz", akár az iserror, akár az iferror függvény működik. Tehát ebben az esetben nem kell az on error goto vagy on error resume next sor és a hozzá kapcsolódó dolgok.Ha iserrort használsz, akkor "csak" arra kell figyelned, hogy a változó, amibe kéred a match eredményét, variantnak legyen definiálva - mivel értéke lehet szám és lehet hibaérték is. Iferrornál nem kerül a változóba hiba, tehát ott jó a double is.
Üdv.
-
Delila_1
veterán
válasz
Delila_1
#23723
üzenetére
Meg is van.
Sub Oszlopok_1()
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
sorhova = WS2.UsedRange.Rows.Count + 1
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
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 -
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 -
Delila_1
veterán
Sub megnyit()
Dim FN As String
FN = "MegadottNev.xlsm"
On Error GoTo Nyit
Workbooks.Open "C:\Temp\proba.xlsx"
On Error GoTo 0
GoTo Folytatas
Nyit:
Workbooks.Open "C:\Temp\alapfile.xlsx"
On Error GoTo 0
Folytatas:
'Ide jön a pár adat kitöltése
'mentés a megadott mappába, az FN változóban megadott névvel
ActiveWorkbook.SaveAs Filename:="C:\Temp\" & FN, FileFormat:= _
xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
End Sub -
Mittu88
senior tag
-
Fferi50
Topikgazda
válasz
Delila_1
#23344
üzenetére
Szia!
Szerintem nem beszéltünk el egymás mellett, de ez nem is lényeges.
A 2010-es exceltől biztosan (de valószínűleg a 2007-ben is már) igen egyszerűen megoldható a feladat:Public fmtcondis As New Collection
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim ujfmtr As FormatCondition, ujfmtc As FormatCondition, ujfmtt As FormatCondition
On Error Resume Next
If IsError(Target.Cells.Count) Then Exit Sub
On Error GoTo 0
If Target.Cells.Count <> 1 Then Exit Sub
If fmtcondis.Count > 0 Then
On Error Resume Next
For Each fmt In fmtcondis
fmt.Delete
fmtcondis.Remove 1
Next
On Error GoTo 0
End If
With Target
With .EntireRow
Set ujfmtr = .FormatConditions.Add(Type:=xlExpression, Formula1:="1")
With ujfmtr '.FormatConditions(1)
With .Borders(xlTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 5
End With
With .Borders(xlBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 5
End With
.Interior.ColorIndex = 20
.SetFirstPriority
End With
End With
fmtcondis.Add ujfmtr, "fmt1"
With .EntireColumn
Set ujfmtc = .FormatConditions.Add(Type:=xlExpression, Formula1:="1")
With ujfmtc '.FormatConditions(1)
With .Borders(xlLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 5
End With
With .Borders(xlRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 5
End With
.Interior.ColorIndex = 20
.SetFirstPriority
End With
End With
fmtcondis.Add ujfmtc, "fmt2"
Set ujfmtt = .FormatConditions.Add(Type:=xlExpression, Formula1:="1")
ujfmtt.Interior.ColorIndex = 36
ujfmtt.SetFirstPriority
fmtcondis.Add ujfmtt, "fmt3"
End With
End SubHiszen itt már be lehet szúrni "akárhány" feltételes formázást és elsőnek tenni, ha pedig megváltozik a kijelölés, akkor az előző formázást törölni.
Ha egy kijelölés közben megváltoztatod az oldalon a feltételes formázási szabályokat, akkor nem tudja a kijelölés elhagyása után letörölni a régi formázást - viszont, ha már úgyis benne vagy a szabályokban, egyszerűen ki kell törölni a kijelölésre vonatkozó feltételes formázásokat, utána az új kijelöléstől már ismét működik az automatizmus.2007. előttre olyan ötletem van, hogy az adott munkalapról csinálni kell egy másolatot és arról minden kijelölés váltásnál vissza kell másolni a formátumot az eredetire.
Üdv.
-
bteebi
veterán
válasz
Delila_1
#23286
üzenetére
Na, így már működik - vagyis egyszer lefut, jól. Azt hogy lehetne megoldani, hogy mindig legyen új inputbox, amíg cancel-t nem nyomok? Úgy a makró újraindítása nélkül több szót is le lehetne cserélni egymás után.
Sub csere()
Dim ws As Worksheet, cserelni As String
On Error Resume Next
Application.DisplayAlerts = False
cserelni = Application.InputBox(Prompt:="Írja be a cserélendő szót.", _
Title:="Csere", Type:=2)
On Error GoTo 0
Application.DisplayAlerts = True
For Each ws In ActiveWorkbook.Worksheets
ws.Cells.Replace What:=cserelni, Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows
Next
End Sub -
bteebi
veterán
válasz
bteebi
#23281
üzenetére
És azt hogy lehetne megcsinálni, hogy egy input box-ba beírt értéket cseréljen le (mindig ugyanarra, ""-re)? Beírnám az értéket, lecseréli, és addig menne, amíg cancel-t nem nyomok.
Mások kódjai alapján egyelőre eddig jutottam, minden bizonnyal több hiba is van benne.
Először is: le se fut, "Object required" hibát ír ki. Meg minden bizonnyal a ws.Cells.Replace What rész se stimmel. Meg tudnátok mondani, hogy hol hibáztam?Sub csere()
Dim ws As Worksheet, cserelni As String
On Error Resume Next
Application.DisplayAlerts = False
Set cserelni = Application.InputBox(Prompt:="Írja be a cserélendő szót.", _
Title:="Csere", Type:=2)
On Error GoTo 0
Application.DisplayAlerts = True
If cserelni Is Nothing Then
Exit Sub
Else
For Each ws In ActiveWorkbook.Worksheets
ws.Cells.Replace What:="cserelni", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows
Next
End If
End Sub -
Fferi50
Topikgazda
válasz
Thrawnad
#23091
üzenetére
Szia!
Nem tudom, Ora milyen változónak lett definiálva.
Valószínűleg azért kapsz ilyen üzenetet, mert nincs a keresett értéknek megfelelő eredmény és így egy hiba értéket ad vissza a Vlookup, amit csak variant tipusu változó tud megenni.Ezért inkább másként szoktuk a problémát megkerülni:
dim talalt as variant
on error resume next
talalt=Application.WorksheetFunction.VLookup(Kod, Sheets("Adatok").Range("E14:ei34"), 16, False)
if err=0 then
volt találat
else
nem volt találat
endif
on error goto 0vagy
dim talalt as variant
talalt=Application.VLookup(Kod, Sheets("Adatok").Range("E14:ei34"), 16, False)
if iserror(talalt) then
nincs találat
else
van találat
endifA dim talalt önmagában is elég, mert az variant tipusu változót deklarál, csak azért írtam oda a típust, hogy jobban feltűnjön.
Üdv.
-
lappy
őstag
válasz
Thrawnad
#23073
üzenetére
Sub FINDSAL()
On Error GoTo MyErrorHandler:
Dim E_name As String
E_name = InputBox("Enter the Employee Name :")
If Len(E_name) > 0 Then
Sal = Application.WorksheetFunction.VLookup(E_name, Sheet1.Range("B3:D13"), 3, False)
MsgBox "Salary is : $ " & Sal
Else
MsgBox ("You entered an invalid value")
End If
Exit Sub
MyErrorHandler:
If Err.Number = 1004 Then
MsgBox "Employee Not Present in the table."
End If
End Sub -
vamzi
senior tag
Szia,
Elhiszem, viszont nem valami kifinomult a PH keresője és lövésem sincs hogy keressek rá, hogy értékelhető találatot kapjak. A hsz-eket pedig kézzel nem szeretném áttúrni.
Jelenleg amúgy ott tartok, hogy kigugliztam egy olyan VBA kódot, ami minden táblázat első sheetjét összemásolja nekem. De mivel nem ismerem a nyelvet, így nem tudom kiegészíteni, hogy a többi sheetet is másolja át.
[link]
Sub MergeAllWorkbooks()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long, FNum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long
' Change this to the path\folder location of your files.
MyPath = "C:\Users\Ron\test"
' Add a slash at the end of the path if needed.
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
' If there are no Excel files in the folder, exit.
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
' Fill the myFiles array with the list of Excel files
' in the search folder.
FNum = 0
Do While FilesInPath <> ""
FNum = FNum + 1
ReDim Preserve MyFiles(1 To FNum)
MyFiles(FNum) = FilesInPath
FilesInPath = Dir()
Loop
' Set various application properties.
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
' Add a new workbook with one sheet.
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1
' Loop through all files in the myFiles array.
If FNum > 0 Then
For FNum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
' Change this range to fit your own needs.
With mybook.Worksheets(1)
Set sourceRange = .Range("A1:C1")
End With
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
' If source range uses all columns then
' skip this file.
If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0
If Not sourceRange Is Nothing Then
SourceRcount = sourceRange.Rows.Count
If rnum + SourceRcount >= BaseWks.Rows.Count Then
MsgBox "There are not enough rows in the target worksheet."
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else
' Copy the file name in column A.
With sourceRange
BaseWks.Cells(rnum, "A"). _
Resize(.Rows.Count).Value = MyFiles(FNum)
End With
' Set the destination range.
Set destrange = BaseWks.Range("B" & rnum)
' Copy the values from the source range
' to the destination range.
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value
rnum = rnum + SourceRcount
End If
End If
mybook.Close savechanges:=False
End If
Next FNum
BaseWks.Columns.AutoFit
End If
ExitTheSub:
' Restore the application properties.
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub -
#22096
Delila_1
veterán
King Unique
#22094
Delila_1
veterán
válasz
King Unique
#22094
üzenetére
Az első kérdéshez:
Private Sub General_Click()
Dim tomb(26), sor As Integer, oszlop As Integer, i As Integer
Dim usor As Integer, uoszlop As Integer
Dim felso As Integer, also As Integer
Range("A1:Z26").ClearContents
Range("A1:Z26").Font.ColorIndex = 0
Randomize
also = 1: felso = 5
usor = Round(Rnd * (felso - also) + also, 0)
felso = Int(26 / usor)
Randomize
uoszlop = Round(Rnd * (felso - also) + also, 0)
For sor = 1 To usor
For oszlop = 1 To uoszlop
Ujra:
Randomize
felso = 26
i = Round(Rnd * (felso - also) + also, 0)
If tomb(i) > 0 Then GoTo Ujra
tomb(i) = i
Cells(sor, oszlop) = Chr(i + 64)
Next
Next
End SubPrivate Sub Kiemel_Click()
Dim terulet As String, CV As Object
Range("A1").Select
terulet = Selection.CurrentRegion.Address
For Each CV In Range(terulet)
If CV.Value Like ("[AEIOU]") Then CV.Font.ColorIndex = 3
Next
End Sub -
Delila_1
veterán
válasz
bepken
#22038
üzenetére
Próbáld ki ezzel:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 3 Then
Application.EnableEvents = False
On Error GoTo Hiba
If Target.Value <> "" Then
Cells(Target.Row, 2) = Date
Cells(Target.Row, 2).NumberFormat = "yy/mm/dd"
Else
Cells(Target.Row, 2) = ""
End If
Application.EnableEvents = True
End If
Exit Sub
Hiba:
MsgBox "Egyszerre csak egy adatot adj meg, vagy törölj!", vbOKOnly + vbExclamation
Application.EnableEvents = True
End Sub -
Delila_1
veterán
Nem tudtam megírni, egy régi kedves barátom segített ki.
A teszt makróban a .StartFolder = "F:\" sorban írd át a meghajtó nevét a sajátodra, majd a ciklusban a jelzett részbe tedd be a másolást, és a megnyitott fájl bezárását. Ezt makrót kell indítanod. Bekéri a keresendő fájlok nevének azt a részét, ami közös, a példád szerint ez valami. A státuszsorban megjelennek a mappák, almappák, ahol a valami kezdetű fájlneveket keresi.
Public Type TFindFile
StartFolder As String
FileName As String
Extension As String
Findings() As String
ErrorCount As Long
End TypeFunction FindFile(Args As TFindFile) As Boolean
Dim Folders() As String, CurrentFolder As String, FolderLevel As Long
Dim FN As String, LookUpName As String
Dim i As Long, Maxi As Long, Mini As Long, FileFound As Boolean
Dim Rng As Range
With Args
ChDrive Left(.StartFolder, 1)
If Right(.StartFolder, 1) <> "\" Then .StartFolder = .StartFolder & "\"
ReDim Folders(1)
Folders(1) = .StartFolder
FolderLevel = UBound(Split(.StartFolder, "\"))
LookUpName = .FileName & "." & .Extension
End With
ReDim Args.Findings(0)
Mini = 1
On Error GoTo hiba
Do
Maxi = UBound(Folders)
For i = Mini To Maxi
FN = Dir(Folders(i) & LookUpName, vbNormal)
While Not FN = ""
FileFound = True
ReDim Preserve Args.Findings(UBound(Args.Findings) + 1)
Args.Findings(UBound(Args.Findings)) = Folders(i) & FN
FN = Dir()
Wend
If UBound(Split(Folders(i), "\")) = FolderLevel Then
FN = Dir(Folders(i) & "*.*", vbDirectory)
While Not FN = ""
If (FN <> ".") And (FN <> "..") Then
If (GetAttr(Folders(i) & FN) And vbDirectory) <> 0 Then
FN = Folders(i) & FN & "\"
ReDim Preserve Folders(UBound(Folders) + 1)
Folders(UBound(Folders)) = FN
Application.StatusBar = FN
End If
End If
FN = Dir()
Wend
End If
DoEvents
Next
Mini = Maxi
FolderLevel = FolderLevel + 1
Loop Until Maxi = UBound(Folders)
If FileFound Then FindFile = True
Application.StatusBar = False
Exit Function
hiba:
Set Rng = Sheets("Hibák").Range("A" & Rows.Count).End(xlUp).Offset(1)
With Rng
.Value = Folders(i)
.Offset(, 1) = FN
.Offset(, 2) = Err.Description
.Offset(, 3) = Err.Number
End With
Args.ErrorCount = Args.ErrorCount + 1
Resume Next
End FunctionSub teszt()
Dim Args As TFindFile
Dim Siker As Boolean, i As Long
With Args
'**************** itt a saját meghajtód nevét írd be! *******
.StartFolder = "F:\"
'****************************************************************
.FileName = InputBox("fájlnév vagy része") & "*"
.Extension = "xlsx"
End With
Siker = FindFile(Args:=Args)
If Siker Then
For i = 1 To UBound(Args.Findings)
Workbooks.Open FileName:=Args.Findings(i)
'****************************************************************
' ide jön a másolás, majd a behívott fájl bezárása
'****************************************************************
Next
Else
MsgBox "Nincs találat."
End If
If Args.ErrorCount > 0 Then
MsgBox Args.ErrorCount & " probléma merült fel, lásd Hibák munkalap."
End If
End Sub -
zhari
csendes tag
Sziasztok!
Végső célom az, hogy egy adott mappa almappáiból meghatározott nevű "cica_*.xlsx"-ek (* természetesen változik) állandó munkalapnevű (munka1) lapokról adott tartományokat egy új táblába egymás alá szeretnék másolni.
Van pár elvileg működő script amiket szeretnék egyesíteni, de nem jön össze.Sub makrófuttatás_almappákban()
Dim lCount As Long
Dim wbResults As Workbook
Dim wbCodeBook As WorkbookApplication.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = FalseOn Error Resume Next
Set wbCodeBook = ThisWorkbook
With Application.FileSearch
.NewSearch
'Change path to suit
.LookIn = "C:\...\egyéb\makrók\teszt"
.FileType = msoFileTypeExcelWorkbooks
.SearchSubFolders = True
'Optional filter with wildcard
'.Filename = "cica*.xls"
If .Execute > 0 Then 'Workbooks in folder
For lCount = 1 To .FoundFiles.Count 'Loop through all
'Open Workbook x and Set a Workbook variable to it
Set wbResults = Workbooks.Open(filename:=.FoundFiles(lCount), UpdateLinks:=0)'DO YOUR CODE HERE
Range("A1").Select
ActiveCell.FormulaR1C1 = "=2"wbResults.Close savechanges:=False
Next lCount
End If
End With
On Error GoTo 0
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
MsgBox "kész"
End SubA fentivel az a bajom, hogy nem tudom meghatározni, hogy milyen nevű táblákkal dolgozzon és mintha nem jó táblákon indítaná a makrót.
Egy másik script ugyanerre:
Sub makrófuttatás_almappákban()
Dim folderPath As String
Dim filename As String
Dim wb As WorkbookfolderPath = "C:\...\egyéb\makrók\teszt" 'change to suit
If Right(folderPath, 1) <> "" Then folderPath = folderPath + ""
filename = Dir(folderPath & "cica2*.xls")
Do While filename <> ""
Application.ScreenUpdating = False
Set wb = Workbooks.Open(folderPath & filename)'Call a subroutine here to operate on the just-opened workbook
Range("A1").Select
ActiveCell.FormulaR1C1 = "=2"
filename = Dir
Loop
Application.ScreenUpdating = True
MsgBox "kész", vbInformation
End SubA fentiek valamelyikét szeretném egyesíteni a következő scripptel.
Sub Fésü()
Const utvonal = "C:\...\egyéb\makrók\teszt" 'Ezt írd át arra a mappára, ahol az xls-eid vannak
Dim FN As String, WB As WorkbookChDir utvonal
FN = Dir(utvonal & "D01_*.xls", vbNormal)
Do
If FN <> "." And FN <> ".." Then
Workbooks.Open Filename:=FN
usor = Range("A65536").End(xlUp).Row 'Behívott füzet alsó soraWindows("02.xlsx").Activate
gy_usor = Range("A65536").End(xlUp).Row 'Gyűjtő füzet alsó soraWindows(FN).Activate 'Behívott füzet
Range(Cells(1, 1), Cells(usor, 12)).Copy 'A oszlop (1:4)Windows("02.xlsx").Activate 'Gyűjtő füzet
Cells(gy_usor, 1).Select
ActiveSheet.Paste
Windows(FN).Activate 'Behívott füzetActiveWorkbook.Save
ActiveWindow.Close
End If
FN = Dir()
Loop Until FN = ""
End SubRemélem érthető volt a problémám. Minden hozzászólást szívesen fogadok.
-
alfa20
senior tag
abban tud valaki segíteni, hogy az alábbi miért nem csatolja be a munkafüzetet?
szeretnék egy makrót, hogy ne keljen mindig ugyan azt megírnom, de a csatolást nem küldi el.
a ".Attachments.Add ActiveWorksheet" sort már próbáltam az alábbiakkal is:
".Attachments.Add ActiveWorksheet.Name"
".Attachments.Add ActiveWorksheet.Fullname"Sub Mail_RE()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "cim@mail.hu"
.CC = ""
.BCC = ""
.Subject = ActiveWorkbook.Name
.Body = "Hello World!" & vbCrLf & vbCrLf & "szia"
.Attachments.Add ActiveWorksheet
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub -
takos
tag
Sziasztok!
Készítettem egy kis makrot, ami elküldi magát az excel fájlt levélként.
Amit nem tudok megoldani, hogy a tárgy mezőben egyszerre több értéket jelenítsen meg és küldjön el a levélben.
Más működik.Pl. szeretném, ha C1, D1, E1 cella tartalma is bekerülne a levél tárgyába.
ez a makro:
Sub level()
Dim OutApp As Object
Dim OutMail As ObjectSet OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)On Error Resume Next
With OutMail
.to = "xy@xy.hu"
.CC = ""
.BCC = ""
.Subject = ThisWorkbook.Sheets("Munka1").Range("C1").Value
.Body = "Teszt uzemmod"
.Attachments.Add ActiveWorkbook.FullName
.Send
End With
On Error GoTo 0Set OutMail = Nothing
Set OutApp = Nothing
End SubÜdv:
takos -
Mutt
senior tag
válasz
alfa20
#20934
üzenetére
Hello,
Olyan makrót tudok készíteni ami megkérdezi melyik oszlop(ok)ból szeretném törölni a nullákat és szépen kitörli?
Ezt tudod használni, csak a kijelölt cellában/oszlopban/sorban töröl:
Sub NullaTorles()
Dim rngTartomany As Range
Dim rngAdatok As Range
On Error GoTo NullaTorles_Error
'kérjük be a tartományt
Set rngTartomany = Application.InputBox("Honnan szeretnéd törőlni a nullákat?", "Választás", , , , , , 8)
'szűkítsük csak a használatban lévő részre
Set rngAdatok = Intersect(rngTartomany, ActiveSheet.UsedRange)
If Not rngAdatok Is Nothing Then
Application.ScreenUpdating = False
rngAdatok.Replace What:="0", Replacement:="", LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False
Application.ScreenUpdating = True
End If
On Error GoTo 0
Exit Sub
NullaTorles_Error:
MsgBox "Kilépés"
End SubHa további nullákat akarsz keresni, akkor esetleg nézd meg így:
WorksheetFunction.CountIf(ActiveSheet.UsedRange, "=0")üdv
-
Delila_1
veterán
Nem biztos, hogy jól értem.
Tehát megnyitsz egy füzetet. Az utolsó oszlop füzetenként máshol van, de mindig az utolsó mínusz 2. oszlopban vannak #N/A értékek, amik szerint a sorokat törölni akarod.Próbáld ezzel a makróval:
Sub HibasSorokTorlese()
Dim usor As Long, oszlop As Long, betu As String
usor = Range("B" & Rows.Count).End(xlUp).Row
oszlop = Range("A1").End(xlToRight).Column
'Utolsó oszlop-2 első sorába a hibákat tartalmazó oszlop betűjele
Cells(1, oszlop + 3) = "=CHAR(" & oszlop - 2 + 64 & ")"
betu = Cells(1, oszlop + 3)
'Autoszűrő kiterjesztése az utolsó oszlop+1 területre
Range(Cells(1, 1), Cells(1, oszlop)).Select
Selection.AutoFilter
Range(Cells(1, 1), Cells(1, oszlop + 1)).Select
Selection.AutoFilter
'Segédoszlopba fejléc
Cells(1, oszlop + 1) = "Hibák"
'Képlet a segédoszlopba
Range(Cells(2, oszlop + 1), Cells(usor, oszlop + 1)) = "=IF(ISERROR(" & betu & "2),1,0)"
'Autoszűrés a hibákat tartalmazó oszlop szerint
On Error GoTo Vege
ActiveSheet.Range(Cells(1), Cells(usor, oszlop + 1)).AutoFilter Field:=oszlop + 1, Criteria1:=1
'Látható sorok kijelölése és törlése
Range("C2:C" & usor).SpecialCells(xlCellTypeVisible).Select
Selection.Rows.Delete shift:=xlUp
Vege:
'Autoszűrő minden megmaradt sort mutasson
ActiveSheet.Range("A1:C" & usor).AutoFilter Field:=oszlop + 1
End Sub -
bteebi
veterán
Sziasztok!
Egy (nekem
) meglehetősen komplex problémám van. Innen-onnan összeszedtem egy kódot, aminek az lenne a feladata, hogy egy (vagy akár több) Excel file kiválasztása után a képleteket jelenítse meg a számolások helyett (működik), széthúzza a cellákat úgy, hogy minden látszódjon és megjelenítse a sor- és oszlopazonosítókat (ez is megy), és elmentse más néven a filet, mondjuk origi.xls helyett origi_mod.xls-ként. A file mentés része nem megy (nem úgy nevezi át, ahogy szeretném.). Ezután még az egész file-t elküldi a nyomtatóra. Ez is viszonylag jól működik, de nem tökéletes: ha xlDefault-nak adom meg a .Orientation-t, akkor hibaüzenettel (400-as hibakód) kilép, ha xlLandscape-nek, akkor lefut. Viszont nem feltétlenül Landscape kellene, mert lennének majd olyan file-ok, amiknél van Landscape/Portrait lap is. Mi lehet a gond?A kód:
Sub ellenorzes()
Dim ablak As FileDialog
Dim fajlnev As String
Set ablak = Application.FileDialog(msoFileDialogOpen)
Dim FileChosen As Integer
FileChosen = ablak.Show
ablak.Title = "Válaszd ki a file-t"
ablak.InitialFileName = "C:\"
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 lap%
For lap% = 1 To Worksheets.Count
Sheets(lap%).Activate
ActiveWindow.DisplayFormulas = True
ActiveSheet.Columns("A:Z").EntireColumn.AutoFit
With ActiveSheet.PageSetup
.PrintHeadings = True
.PaperSize = xlPaperA4
.Orientation = xlLandscape
End With
Next
ActiveWorkbook.SaveAs FileName:=ActiveWorkbook.Name & "_mod"
If MsgBox("Kinyomtatja az összes munkalapot?", vbInformation + vbYesNo, "Munkalapok kinyomtatása") = vbYes Then
ActiveWorkbook.PrintOut
Else: Exit Sub
End If
End SubTovábbi problémák, észrevételek:
1. Első futáskor nem alkalmazza a szűrőket (.xls, .xlsx, kiindulási mappa). Másodjára már igen, még akkor is, ha csak elindítom a makrót, de nem választok ki file-t, tehát kilépek.
2. A file megnyitása párbeszédpanelnél hogy lehetne a Sajátgépet, vagy azt a mappát kiválasztani, amelyikben az adott file van (amiből a makró fut)?
3. Save as-nél probléma: a "_mod"-dal kiegészítve nem pont úgy írja át, ahogy szeretném: a filenév végéhez írja a "_mod"-ot, a kiterjesztés után. Ezt meg lehetne kerülni a kiterjesztést jelölő pont előtti/utáni részre való szűréssel. Ezt viszont egyrészt én nem tudnom megírni, ráadásul ha a filenévben is van pont, akkor a "legjobboldalibb" pont előtti/utáni részre kellene szűrni.
4. Nekem úgy lenne logikus, ha az "If FileChosen = 1" lenne, de úgy nem csinál semmit, csak a -1-re. A kód, ami alapján csináltam, így volt:
If FileChosen <> -1 Then
Else
fajlnev = ablak.SelectedItems(1)
Workbooks.Open (fajlnev)5. Ha meg van nyitva a módosítani kívánt file (pl. az előző makrófutás után nyitva maradt), és azt nem írom felül, akkor hibaüzenetet ad. (A kódot az ActiveWorkbook.SaveAs sor nélkül futtattam, mivel az nem működött.)
6. Hogy lehetne a "400" hibaüzenet okát kiíratni? Ilyet találtam, hogy
On Error GoTo Errorcatch
and at the end of the code put
exit sub
Errorcatch:
MsgBox Err.Description
De ezt sehogy se tudtam működésre bírni. Eleve ha Exit Sub-ot írtam a kód legvégére, akkor Compile Error van (End Sub-ot kér).
7. Hogy lehetne azt megoldani, hogy a file mentésénél is legyen egy párbeszédpanel, aminek a default mappája vagy egy általam megadott hely lenne (pl. C:\mod\), vagy pedig a) a makrót tartalmazó file útja, esetleg b) a módosítani kívánt file útja.
8. Hogy lehetne mindezt megcsinálni több file-lal egyszerre? Több file-t is ki lehet jelölni, de a makró csak egy file-on fut le.Bocsánat, kicsit hosszúra sikeredett
. Egyelőre itt tartok. Természetesen tovább próbálkozom majd a hibák kijavításával. Minden javaslatot, javítást nagyon köszönök! -
Delila_1
veterán
válasz
vigyori78
#20238
üzenetére
Első lépésként a gif-et szét kell szedned az alkotó rétegeire. Erre kiválóan alkalmas a PhotoShop. Az egyes rétegeket 1.gif, 2.gif, ... n.gif néven mentsd el egy könyvtárba.
A lapodra az ActiveX vezérlők közül kiteszel egy képet, aminek hivatalból Image1 lesz a neve, amit megváltoztathaszt, és akkor a makróban is át kell írnod.
Érdemes még egy gombot is kitenni, ami leállítja a "mozgás"-t. Nálam ez a gomb Kikapcs névre hallgat.
Az én gifem 10 rétegből állt, a tied jóval többől, ennek megfelelően írd át azIf x = 10 Then x = 1 Else x = x + 1
sort. Az útvonalat is át kell írnod.
A laphoz rendeld az alábbi két makrót.
Private Sub Worksheet_Activate()
Dim MyTimer As Double, x As Integer, utvonal As String
bekapcs = True
utvonal = "C:\Documents and Settings\Felhasználó\Dokumentumok\Képek\"
DoEvents
x = 1: MyTimer = Timer
Do
On Error Resume Next
ActiveSheet.Image1.Picture = LoadPicture(ThisWorkbook.Path & utvonal & x & ".Gif")
On Error GoTo 0
Do
Loop While Timer - MyTimer < 0.07
If x = 10 Then x = 1 Else x = x + 1
MyTimer = Timer
DoEvents
Loop While bekapcs = True
End SubPrivate Sub Kikapcs_Click()
bekapcs = False
End SubAz Image1 tulajdonságainál beállíthatod, hogy ne legyen keret (BorderStyle=0-fmBorderStyleNone), ne legyen kitöltés (BackStyle=fmBackStyleTransparent), és még amit akarsz.
-
Attas
aktív tag
válasz
Delila_1
#20187
üzenetére
Szia Delila!
Mint már oly sokszor, most is köszönöm a segítséged! Valamiért nem működik. Kicsit átalakítottam, mert azt szeretném, ha a makró tartalmazná a keresési feltételeket. Vagy esetleg a Munk4 A1 és B1 cellája. A makró lefut de nem visz át időadatot.Sub Atmasol()
Dim WS As Worksheet, sor As Long, usor As Long, v$, WF As WorksheetFunction
Dim oszlop As Integer, sor1 As Long, f As Boolean
Application.ScreenUpdating = False
Set WF = Application.WorksheetFunction
Sheets("Adatok").Activate
v$ = "C"
If v$ = "B" Or v$ = "b" Then
Set WS = Sheets("Munka2")
oszlop = 2
v$ = "AF230"
GoTo Keres
End If
If v$ = "C" Or v$ = "c" Then
Set WS = Sheets("Munka1")
oszlop = 3
v$ = "AF0230M01SP1-Station2"
GoTo Keres
End If
Exit Sub
Keres:
usor = WF.CountA(Columns(oszlop))
f = False
For sor = 1 To usor
If Cells(sor, oszlop) = v$ Then
If WS.Range("C6") = "" Then sor1 = 6 Else sor1 = WS.Range("C" & Rows.Count).End(xlUp).Row + 1
Cells(sor, "D").Copy WS.Cells(sor1, "C")
f = True
End If
Next
'Rendezés
WS.Activate
Range("C6").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Sort Key1:=Range("C6"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Sheets("Adatok").Activate
Application.ScreenUpdating = True
End Sub -
Delila_1
veterán
Azt nem írtad, hogy ha a B oszlopból választasz kigyűjtendő adatot, hova írja. Úgy írtam meg a makrót, hogy B választáskor a Munka2, C-nél pedig a Munka1 lapra gyűjtsön ki.
Az adatokat az Adatok lap tartalmazza. Ezt kell átírnod a makróban 2 helyen a saját lapod nevére.Sub Atmasol()
Dim WS As Worksheet, sor As Long, usor As Long, v$, WF As WorksheetFunction
Dim oszlop As Integer, sor1 As Long, f As Boolean
Application.ScreenUpdating = False
Set WF = Application.WorksheetFunction
Sheets("Adatok").Activate
v$ = Application.InputBox("B, vagy C oszlop szerint akarsz másolni?", "Oszlop választás", , , , , , 2)
If v$ = "B" Or v$ = "b" Then
Set WS = Sheets("Munka2")
oszlop = 2
v$ = Application.InputBox("Kérem a keresendő B értéket", "Adat választás", , , , , , 2)
GoTo Keres
End If
If v$ = "C" Or v$ = "c" Then
Set WS = Sheets("Munka1")
oszlop = 3
v$ = Application.InputBox("Kérem a keresendő C értéket", "Adat választás", , , , , , 2)
GoTo Keres
End If
MsgBox "B vagy C értéket írhatsz", vbOKOnly + vbExclamation
Exit Sub
Keres:
usor = WF.CountA(Columns(oszlop))
f = False
For sor = 1 To usor
If Cells(sor, oszlop) = v$ Then
If WS.Range("C6") = "" Then sor1 = 6 Else sor1 = WS.Range("C" & Rows.Count).End(xlUp).Row + 1
Cells(sor, "D").Copy WS.Cells(sor1, "C")
f = True
End If
Next
'Rendezés
WS.Activate
Range("C6").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Sort Key1:=Range("C6"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Sheets("Adatok").Activate
Application.ScreenUpdating = True
If f = False Then MsgBox "Nincs a tartományban " & v$ & " érték", vbOKOnly
End Sub -
#20172
the radish
senior tag
the radish
senior tag
Sziasztok!
Adott az alábbi macro:
Sub Mail_Workbook_1()
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, Outlook 2010.
' This example sends the last saved version of the Activeworkbook object .
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
' Change the mail address and subject in the macro before you run it.
With OutMail
.To = "akármi@akármi.hu"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hello World!"
.Attachments.Add ActiveWorkbook.FullName
' You can add other files by uncommenting the following line.
'.Attachments.Add ("C:\test.txt")
' In place of the following statement, you can use ".Display" to
' display the mail.
.Send
End With
On Error GoTo 0Azonban 2003-as office-ban küldés előtt ez az ablak jelenik meg és nem is küldi el, csak ha az igen-re klikkelek:
(2013-asban jól működik)
Kérdés: Van-e lehetőség arra, hogy kérdés nélkül küldje az emailt?
-
Mutt
senior tag
válasz
Wollie
#19998
üzenetére
Hello,
Olyan feladatom van, hogy egy oszlopban szereplő szövegek "féleségét" kell megszámolnom...
Egyedi rekordok számolására több megoldás is van.
1. Képlet
Delila1 által megadott szorzatösszeges képlet jó. Ugyanez CSE képlettel:
{=SZUM(1/DARABTELI(tartomany;tartomany))}Ha a tartományban van üres cella, akkor az ezt kezelő képlet a következő:
=SZUM(HAHIBA(1/DARABTELI(tartomany;tartomany);1/DARABÜRES(tartomany)))2. Pivot (Kimutatás) használata
3. Addin használata
Számos kiegészítő van, amelyben készen van erre megoldás. pl. Az ingyenes ASAP utilitiesben megtalálható.
4. Saját makró használata
Function Egyedi(Adatsor As Range, Optional UresCellaIsKell As Boolean = True)
Dim vLista As New Collection
Dim cella As Range
On Error Resume Next
For Each cella In Adatsor
If UresCellaIsKell Then
vLista.Add cella, CStr(cella)
Else
If Len(cella) > 0 Then vLista.Add cella, CStr(cella)
End If
Next cella
On Error GoTo 0
Egyedi = vLista.Count
End Functionüdv
-
Mutt
senior tag
válasz
Nyomdász
#19454
üzenetére
Hello,
Tömbfüggvénnyel esetleg megoldható, illetve az újabb változatokban van GYAKORISÁG függvény, de ez sem segít sokat.
A javaslatom egy saját függvény használata. Feltöltöttem ide egy mintával:
https://www.sugarsync.com/pf/D0303523_164_627981888
A függvénnyel mind a legtöbbször, mind a legkevesebbszer használt számokat meg lehet kapni.
A kód a pedig:
Function GYAKORI(Tartomany As Range, Elem As Long, Optional Kicsi As Boolean = False, Optional Rendezetlen As Boolean = False)
Dim Adatok As New Collection 'egyedi számok tömbje
Dim arryAdatok() 'végső tömb
Dim rngAdatsor As Range 'adatokat tartalmazó terület
Dim cell As Range
Dim i As Long
'csak a kijelölt és számokat tartalmazó terület metszetét vizsgáljuk
Set rngAdatsor = Intersect(Tartomany, ActiveSheet.Cells.SpecialCells(xlCellTypeConstants, xlNumbers))
'a collection-be felvesszük a számokat, mivel csak egyedi értékeket
'tud fogadni, ezért ki kell kapcsolni a hibakezelést
On Error Resume Next
'végigmegyünk az adatterületen és felvesszük a collection-be
For Each cell In rngAdatsor
Adatok.Add cell.Value, CStr(cell.Value)
Next cell
'hibakezelés visszakapcsolása
On Error GoTo 0
'létrehozunk egy két dimenziós tömböt: számokat és gyakoriságukat fogjuk tárolni
ReDim arryAdatok(1 To Adatok.Count, 1 To 2)
'feltöltjük a tömböt
For i = 1 To UBound(arryAdatok, 1)
'számérték
arryAdatok(i, 2) = Adatok.Item(i)
'számérték gyakorisága - DARABTELI-vel határozzuk meg
arryAdatok(i, 1) = WorksheetFunction.CountIf(rngAdatsor, Adatok.Item(i))
Next i
'sorbarendezzük a számokat alapból (ha a rendezetlen IGAZ-ra van állítva akkor nem fut le)
If Not Rendezetlen Then
BubbleSort arryAdatok, 2
End If
'a gyakoriság (első dimenzió) szerint növekvő sorrendbe tesszük a tömböt
'buborék rendezés kódja innen származik
'http://social.msdn.microsoft.com/Forums/en-US/320f3328-cb4f-43ce-aedf-c0f00f253b64/sorting-a-2-dimension-array-in-excel-vba?forum=isvvba
BubbleSort arryAdatok, 1
'ha KICSI-ként használjuk a függvényt, akkor a tömb első elemei kellenek
'ha NAGY-ként akkor viszont az utolsók
If Not Kicsi Then
Elem = UBound(arryAdatok, 1) - Elem + 1
End If
'eredmény
GYAKORI = arryAdatok(Elem, 2)
End Functionüdv.
-
#19138
Delila_1
veterán
ElemiKoczka
#19120
Delila_1
veterán
válasz
ElemiKoczka
#19120
üzenetére
Rájöttem, hogy a #19121-ben nem azt a választ adtam, amire vártál.
Kerek óránál 600-t írj, 12:42-höz elég 1242-t írnod, 0:54-nél 054-et.Private Sub Worksheet_Change(ByVal Target As Range)
Dim ido, ertek
If Not Intersect(Target, [A:B]) Is Nothing Then
If Range(Target.Address) = "" Then Exit Sub
Application.EnableEvents = False
On Error GoTo Hiba
ertek = Target * 1
If ertek > 2359 Or ertek < 0 Or Right(ertek, 2) > 59 Then
GoTo Hiba
Else
Select Case Len(ertek)
Case 1, 2
ido = "00:" & ertek
Case 3
ido = "0" & Left(ertek, 1) & ":" & Right(ertek, 2)
Case Else
ido = Left(Target, 2) & ":" & Right(Target, 2)
End Select
Range(Target.Address) = Format(ido, "hh:mm")
End If
End If
Application.EnableEvents = True
Exit Sub
Hiba:
MsgBox "Hiba!" & Chr(10) & "Ilyen időpont nem létezik", vbInformation
Range(Target.Address).Select
Application.EnableEvents = True
End Sub -
Delila_1
veterán
válasz
Tompkins
#18176
üzenetére
Megnéztem lépésenként. Mikor a 97-es értéknél az összeg 14003, ennek a hosszát 4-nek értékeli a tükrözésnél, ezért a tükörképét 41-nek hozza ki. A
For b = Len(osszeg) To 1 Step -1
sort (Do-Loop cikluson belül) megváltoztattam,
For b = Len(osszeg & "") To 1 Step -1
lett, így hozza a 6 db-os értéket. 395-nél és 584-nél 7 az érték.
Az
If Len(szam1) = 0 Then Tukroz = 0: GoTo Vege
sorban is a stringgé alakított forma hosszától indítom a ciklust:
If Len(szam1 & "") = 0 Then Tukroz = 0: GoTo Vege
-
Delila_1
veterán
válasz
Tompkins
#18164
üzenetére
Közben sok számmal kipróbáltam. Vannak olyanok, ahol vagy egyáltalán nincs megoldás, vagy túl nagy az eredmény. A dimenzionálásnál az Integer-ek helyére Long-ot írtam, és megadtam egy határt (1000), ami után ne számoljon tovább, hanem írjon ki egy szöveget. Ezt a jelölt sorban módosíthatod a türelmednek megfelelően.
Function Tukroz(szam As Long)
Dim ford, b As Long, darab As Long, osszeg As Long, szam1 As Long
szam1 = szam
If Len(szam1) = 0 Then Tukroz = 0: GoTo Vege
For b = Len(szam1) To 1 Step -1
ford = ford & Mid(szam, b, 1)
Next
If szam = ford * 1 Then
Tukroz = 0: GoTo Vege
Else
Do
osszeg = szam1 + ford
ford = ""
darab = darab + 1
If darab > 1000 Then 'Itt módosíthatsz
Tukroz = "Nincs megoldás, vagy 1000-nél nagyobb": GoTo Vege
Else
For b = Len(osszeg) To 1 Step -1
ford = ford & Mid(osszeg, b, 1)
Next
szam1 = osszeg
If szam1 = ford * 1 Then
Tukroz = darab: GoTo Vege
End If
End If
Loop While szam1 <> ford * 1
End If
Tukroz = darab
Vege:
End Function -
Delila_1
veterán
válasz
Tompkins
#18164
üzenetére
Írtam egy funkciót rá, de csak az általad megadott számokkal ellenőriztem. Azokkal OK.
Function Tukroz(szam As Integer)
Dim ford, b As Integer, darab As Integer, osszeg As Long, szam1 As Long
szam1 = szam
If Len(szam1) = 0 Then Tukroz = 0: GoTo Vege
For b = Len(szam1) To 1 Step -1
ford = ford & Mid(szam, b, 1)
Next
If szam = ford * 1 Then
Tukroz = 0: GoTo Vege
Else
Do
osszeg = szam1 + ford
ford = ""
darab = darab + 1
For b = Len(osszeg) To 1 Step -1
ford = ford & Mid(osszeg, b, 1)
Next
szam1 = osszeg
If szam1 = ford * 1 Then
Tukroz = darab: GoTo Vege
End If
Loop While szam1 <> ford * 1
End If
Tukroz = darab
Vege:
End Function -
Delila_1
veterán
válasz
alfa20
#17811
üzenetére
Itt legalább látszik a makróban a tagolás.
A ciklust a 2. sortól indítottam, feltételezve, hogy van címsorod.Sub Valami()
Dim sor%, usor%, szoveg$, f As Boolean
usor% = Range("A" & Rows.Count).End(xlUp).Row
For sor% = 2 To usor%
If InStr(Cells(sor%, 1), "alma") And _
InStr(Cells(sor%, 1), "körte") Then
szoveg$ = "Van almád és körtéd"
f = True: GoTo Kiiras
End If
If InStr(Cells(sor%, 1), "alma") Then
szoveg$ = "Van almád"
f = True: GoTo Kiiras
End If
If InStr(Cells(sor%, 1), "körte") Then
szoveg$ = "Van körtéd"
f = True: GoTo Kiiras
End If
Kiiras:
If f Then
MsgBox szoveg$
Else
MsgBox "Semmid sincs"
End If
szoveg$ = "": f = False
Next
End Sub -
#17205
m.zmrzlina
senior tag
m.zmrzlina
senior tag
Létezik e az Application.ScreenUpdating-nek oprendszer szinten is működő változata.
Az a gondom, hogy van egy makróm ami azt csinálja, hogy
1. megnyit egy fájlt
2.kiír belőle bizonyos adatokat
3.bezárja a fájlt
4. GoTo 1 (kb 1000-szer)Ezalatt a tálcaikonok folyamatosan változnak (a megnyitás-bezárások miatt) egy kicsit "hektikussá" téve a makró futását.
Ezért szeretném letiltani a képernyőfrissítést rendszerszinten.
-
#17182
Delila_1
veterán
m.zmrzlina
#17180
Delila_1
veterán
válasz
m.zmrzlina
#17180
üzenetére
Próbáltad lenullázni a hibakódot a hianyzoport végén on error goto 0-val?
-
#17180
m.zmrzlina
senior tag
m.zmrzlina
senior tag
Van egy ilyen kódrészletem:
Range("C" & intMeterfejlec & ":D" & intMeterfejlec_vege).Select
On Error GoTo hianyzoport:
intPorthol = Selection.Find(What:=strPort, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row
If Mid(Cells(intPorthol + 4, 5).Value, 9, 4) <> "UNDF" Then
strPortmap(1, intKovport) = Mid(Cells(intPorthol + 4, 5).Value, 9, 4)
intKovport = intKovport + 1
Else
strPortmap(1, intKovport) = Empty
intKovport = intKovport + 1
End If
hianyzoport:
If Err.Number <> 0 Then
strPortmap(1, intKovport) = "NONE"
intKovport = intKovport + 1
End IfEz egy számlálós ciklus belsejében van és azt csinálja, egy kijelölt tartományon belül megkeres egy értéket (strPort változó) és ettől a cellától meghatározott (sor, oszlop) távolságra lévő cella tartalmának bizonyos részét beleírja egy tömb megfelelő helyére (ha az megfelel bizonyos feltételeknek) Ha nem találja a strPort változót akkor hibára fut és a kérdéses tömbelem "NONE" lesz.
A probléma az, hogy az első hibánál szépen lefut a hibakezelés (elugrik a kód a hianyzoport: cimkére) a második esetben azonban Object variable or With block variable not set (Error 91) hibával kiakad.
Kérdés: miért fut le először jól és miért akad ki ugyanannál a hibánál másodszor?
-
#17157
m.zmrzlina
senior tag
Mutt
#17118
m.zmrzlina
senior tag
Ez kiváló pont ilyesmire van szükségem.
Hogyan lehet ezt a linkedcell értéket futásidőben változtatni?
Az lenne a cél, hogy (megkönnyítendő az adatbevitelt) egér használata nélkül:
1. pl A1-be írok egy számot
2.Linkedcell értéke AktiveCell.Offset(0,1)
3.Enter-re megkapja a Combobox a fókuszt
4.kiválasztom a ListfillRange elemeiből a kívántat
5.Enterre beíródik a Combobox tartalma LinkedCell-be, ez esetben ("B1")
6.(A oszlop első nem üres cellája).Select (eggyel lejjebb ugrik az aktív cella)
7. GoTo 2 -
#17070
m.zmrzlina
senior tag
Delila_1
#17069
m.zmrzlina
senior tag
válasz
Delila_1
#17069
üzenetére
Az On Error Resume Next megadásakor nem áll le a program, hanem a következő sorra ugrik.
És ezt mindaddig csinálja amíg az Az On Error Goto 0 ki nem kapcsolja.
Ez volt a probléma. Korábban volt egy Resume Next és nem volt utána Goto 0
Köszi
Az automatikus kiegészítére valakinek valami ötlet?
-
#17069
Delila_1
veterán
m.zmrzlina
#17068
Delila_1
veterán
válasz
m.zmrzlina
#17068
üzenetére
Az On Error Resume Next megadásakor nem áll le a program, hanem a következő sorra ugrik.
Az On Error Goto 0 kapcsolja ki.Amit küldtem, abban az On Error Goto Hiba sorral a Hiba címkére küldöm hiba esetén, ami egy üzenetet küld arról, hogy létezik már azonos nevű lap.
-
Mutt
senior tag
válasz
Aladaar
#16814
üzenetére
Hello,
2. adott egy táblázat, aminek az egyik oszlopában ha rászűrök egy-egy értékre, akkor azt szeretném, hogy az az érték látszódjon a táblázat felett egy külön cellában is.
Csak makróval megy és ha több kijelölésed van akkor is csak az első mutatja, itt a minta.
A szűrő feletti cellába tedd ezt (a filter tartományom A2:A11 volt):
=IF(SUBTOTAL(3;A$2:A$11)="";"";FilterCriteria(A$2))A kód pedig:
Public Function FilterCriteria(rng As Range) As String
Dim Filter As String
On Error GoTo Finish
With rng.Parent.AutoFilter
If Intersect(rng, .Range) Is Nothing Then GoTo Finish
With .Filters(rng.Column - .Range.Column + 1)
If Not .On Then GoTo Finish
If .Criteria1 <> "" Then Filter = .Criteria1
End With
End With
Finish:
FilterCriteria = Replace(Replace(Filter, "*", ""), "=", "")
If Filter = "" Then FilterCriteria = ""
End Functionüdv.
Valami nem jo. Csak az utolso esetben csinalja azt, amit kell, az összes többiben nem.
![;]](http://cdn.rios.hu/dl/s/v1.gif)
de ez hogyan is akar működni? bezárás előtt beleír a táblázatba, amitől az megváltozik. ilyenkor nem ajánlja fel a mentést az ekcszell? mert akkor megint ment, de ugye afters
52 (itt van a sablonszöveg) cellákat úgy, hogy a nyílván megmaradjon a formátuma is A1
Ha kevesebb dolgom lesz, megpróbálom azt a formát kihozni.
Új hozzászólás Aktív témák
Hirdetés
- LG 77G4 - 77" OLED evo - 4K 144Hz 0.1ms - MLA - 3000 Nits - NVIDIA G-Sync - AMD FreeSync - HDMI 2.1
- BESZÁMÍTÁS! ASRock B250 i5 6600 16GB DDR4 256 SSD 500GB HDD GTX 1050 2GB Zalman Z1 Njoy 550W
- ÁRGARANCIA!Épített KomPhone Ryzen 5 5600X 16/32/64GB RAM RX 7600 8GB GAMER PC termékbeszámítással
- Új, verhetetlen alaplap sok extrával!
- ÁRGARANCIA!Épített KomPhone i5 12400F 16/32/64GB RAM RX 7600 XT 16GB GAMER PC termékbeszámítással
Állásajánlatok
Cég: Promenade Publishing House Kft.
Város: Budapest
Cég: CAMERA-PRO Hungary Kft
Város: Budapest