- Fotók, videók mobillal
- iPhone topik
- 45 wattos vezeték nélküli töltés jön az új iPhone-ba
- VoLTE/VoWiFi
- Bemutatkozott a Poco X7 és X7 Pro
- Milyen okostelefont vegyek?
- Xiaomi 14T Pro - teljes a család?
- Honor Magic6 Pro - kör közepén számok
- Android alkalmazások - szoftver kibeszélő topik
- Huawei Mate X6 - keleti oldal, nyugati oldal
-
Mobilarena
A Microsoft Excel topic célja segítséget kérni és nyújtani Excellel kapcsolatos problémákra.
Kérdés felvetése előtt olvasd el, ha még nem tetted.
Új hozzászólás Aktív témák
-
Declare
őstag
válasz
Declare
#40435
üzenetére
egy kis Update:
a összes tesztelt olyan 2018 as datumra lefut, ami 0 val kezdödik ( 02.11.18 ; 06.10.18 stb.). Ha viszont nem 0 val kezdödik akkor a 2018 as datumokkal nem fut a makro (vagy lefut de nem talal semmit). 2019 es evvel semmi problema, akarmilyen datummal lefut
-
Fferi50
Topikgazda
válasz
Declare
#40421
üzenetére
Szia!
"ha datumot beirom az inputboxba, nem törtenik semmi"
Történik, annyi, hogy nem találja meg amit keresel. Dátumot csak dátumként lehet keresni. Az inputboxba pedig nem tudsz dátumot beírni közvetlenül.
Szövegként tudod beírni és utána átalakítani dátummá.
Pl.OK = Application.InputBox("Wonach soll gesucht werden? ",type:=2) 'szöveget kell bevinni az érvényes rendszer dátumformátumban, pl. magyarban éééé.hh.nn
Set c = .Find(Datevalue(OK), LookIn:=xlValues)De probléma lehet az is, ha a keresendő oszlopban nem dátumok, hanem dátumnak látszó szöveges értékek vannak! Erről meggyőződhetsz, ha a cella formátumát megváltoztatod számra - ha dátum volt benne, akkor számot fogsz látni, ha nem, akkor az eredeti értéket. Természetesen vissza is lehet változtatni.
Ha dátumnak látszó szöveg van, akkor olyan formátumú szöveg kell legyen a keresés is.Üdv.
-
Fferi50
Topikgazda
válasz
Declare
#40412
üzenetére
Szia!
1. Akkor valami nincs rendben nálad, mert ez a parancssorWorksheets.Add(After:=Sheets(Sheets.Count)).Name = newSheetName
mindig az utolsó után szúrja be az új munkalapot. Mindegy, hogy melyik munkalapról indítod.
Esetleg lehagytad az zárójeles paramétert, vagy a Before paramétert használod?2. Ha gond van vele kérdezz bátran.
Üdv.
-
Fferi50
Topikgazda
válasz
Declare
#33301
üzenetére
Szia!
Egy picit kellett módosítani rajta:
Sub adogat()
Dim kezdrng As Range, vegrng As Range, ws1 As Worksheet, celrng As Range, elsocim As String, gewerkrng As Range, kezdocim As String ' a második ciklus kezdőcímének tárolására
Set ws1 = ActiveSheet
'megkeressük az elso S. Titel cellát:
Set vegrng = ws1.Columns("G").Find(what:="S. Titel", LookIn:=xlValues, lookat:=xlWhole, searchdirection:=xlNext, After:=Range("G1"))
elsocim = vegrng.Address 'megjegyezzük a címét, mert itt kell leállítani
Do While Not vegrng Is Nothing
'megkeressük a kezdo sort / Titel /
Set kezdrng = ws1.Columns("G").Find(what:="Titel", LookIn:=xlValues, lookat:=xlWhole, After:=vegrng, searchdirection:=xlPrevious)
If kezdrng.Row < vegrng.Row Then 'ha kisebb mint az S. Titel helye, akkor összeadjuk
vegrng.Offset(0, -1).Formula = "=Sum(" & kezdrng.Offset(2, -1).Address & ":" & vegrng.Offset(-1, -1).Address & ")"
vegrng.Offset(0, -1).NumberFormat = "#,##0.00 $"
vegrng.Offset(0, -1).HorizontalAlignment = xlRight
End If
'következo S. Titel
Set vegrng = ws1.Columns("G").Find(what:="S. Titel", LookIn:=xlValues, lookat:=xlWhole, After:=vegrng, searchdirection:=xlNext)
If vegrng.Address = elsocim Then Exit Do 'ha visszaértünk az elsohöz, kilépünk
Loop
'megkeressük az elso S. Gewerk cellát:
Set vegrng = ws1.Columns("G").Find(what:="S. Bereich", LookIn:=xlValues, lookat:=xlWhole, searchdirection:=xlNext, After:=Range("G1"))
elsocim = vegrng.Address: Set gewerkrng = Range("G1") 'megjegyezzük a helyét és a lehetséges elso cellát
Do While Not vegrng Is Nothing
'megkeressük az elso S. Titelt a Gewerkben
Set kezdrng = ws1.Columns("G").Find(what:="S. Titel", LookIn:=xlValues, lookat:=xlWhole, After:=vegrng, searchdirection:=xlPrevious)
kezdocim = kezdrng.Address
Set celrng = kezdrng
Do While Not kezdrng Is Nothing
If kezdrng.Row > gewerkrng.Row Then ' ha benne van a tartományban
If kezdrng.Row < vegrng.Row Then ' és oda tartozik, akkor bevesszük az összesítésbe
Set celrng = Union(kezdrng, celrng)
Else
vegrng.Offset(0, -1).Formula = "=Sum(" & celrng.Offset(0, -1).Address & ")" 'ha nincs benne, akkor beírjuk az összesíto képletet
vegrng.Offset(0, -1).NumberFormat = "#,##0.00 $"
vegrng.Offset(0, -1).Font.Bold = True
vegrng.Offset(0, -1).HorizontalAlignment = xlRight
Exit Do
End If
Else
vegrng.Offset(0, -1).Formula = "=Sum(" & celrng.Offset(0, -1).Address & ")" ' ha már az elozo Gewerkhez visszaértünk, akkor beírjuk az összesíto képletet
vegrng.Offset(0, -1).NumberFormat = "#,##0.00 $"
vegrng.Offset(0, -1).Font.Bold = True
vegrng.Offset(0, -1).HorizontalAlignment = xlRight
Exit Do
End If
'megkeressük a következo S. Titel cellát:
Set kezdrng = ws1.Columns("G").Find(what:="S. Titel", LookIn:=xlValues, lookat:=xlWhole, After:=kezdrng, searchdirection:=xlPrevious)
If kezdrng.Address = kezdocim Then Exit Do 'ha nincs több S. Titel, akkor kilépünk EZ AZ EGYIK ÚJ SOR
Loop
Set gewerkrng = vegrng ' a Gewerk területet változtatjuk
'megkeressük a következo S. Gewerk cellát:
Set vegrng = ws1.Columns("G").Find(what:="S. Bereich", LookIn:=xlValues, lookat:=xlWhole, After:=vegrng, searchdirection:=xlNext)
'INNEN MÓDOSULT
If vegrng.Address = elsocim Then 'ha visszaértünk az elso találathoz
If Application.IsFormula(vegrng.Offset(0, -1)) Then 'és már van képletünk, akkor végeztünk
Exit Do
Else ' egyébként betesszük a képletet és utána végeztünk
vegrng.Offset(0, -1).Formula = "=Sum(" & celrng.Offset(0, -1).Address & ")" ' ha már az elozo Gewerkhez visszaértünk, akkor beírjuk az összesíto képletet
vegrng.Offset(0, -1).NumberFormat = "#,##0.00 $"
vegrng.Offset(0, -1).Font.Bold = True
vegrng.Offset(0, -1).HorizontalAlignment = xlRight
Exit Do
End If
End If
Loop
End Sub
Remélem így már rendben lesz.Üdv.
-
Delila_1
veterán
válasz
Declare
#32811
üzenetére
Sub HarmasFeladat()
Dim sor As Long, usor As Long
Application.ScreenUpdating = False
usor = Range("F" & Rows.Count).End(xlUp).Row
For sor = 2 To usor
Select Case Cells(sor, "F")
Case "Value1"
Cells(sor, "H") = "=F" & sor
Case "Value2"
Cells(sor, "I") = "=F" & sor
Case "Value3"
Cells(sor, "J") = "=F" & sor
End Select
Next
Application.ScreenUpdating = True
End Sub -
Delila_1
veterán
válasz
Declare
#32811
üzenetére
Tényleg működik az egyenlőség jeles, de anélkül is.
A bemásolt makród is hiba nélkül lefut nálam üres sorok esetén is, csak ugrál. Először az alsó Value2 sorba ír, majd az első Value1-be, utolsó Value3-ba, első Value2-be, stb.
Az én makrómban a
Do While Cells(sor, "G") > ""
sorban a G-t írd át F-re. -
Delila_1
veterán
válasz
Declare
#32807
üzenetére
Azt hiszem, túlbonyolítod a feladatot. Minek ide-oda ugrálni? Elég egyszer végigmenni az adatokon.
A makróban elég bugyuta feladatokat adtam meg a 3 különböző értékre.
Value1-nél a H oszlop azonos sorába írja be hivatkozással az F aktuális sorának az értékét. a másik kettőnél az I-be, ill. a J-be.Sub HarmasFeladat()
Dim sor As Long
Application.ScreenUpdating = False
sor = 2
Do While Cells(sor, "G") > ""
Select Case Cells(sor, "G")
Case "Value1"
Cells(sor, "H") = "=F" & sor
Case "Value2"
Cells(sor, "I") = "=F" & sor
Case "Value3"
Cells(sor, "J") = "=F" & sor
End Select
sor = sor + 1
Loop
Application.ScreenUpdating = True
End Sub -
Fferi50
Topikgazda
válasz
Declare
#32697
üzenetére
Szia!
Az alábbi makrót okoskodtam össze, feltétel, hogy minden S. Titel előtt a G oszlopban legyen Titel:
Sub osszeado()
Dim kezdrng As Range, vegrng As Range, ws1 As Worksheet, celrng As Range, elsocim As String, gewerkrng As Range
Set ws1 = ActiveSheet
'megkeressük az első S. Titel cellát:
Set vegrng = ws1.Columns("G").Find(what:="S. Titel", LookIn:=xlValues, lookat:=xlWhole, searchdirection:=xlNext, after:=Range("G1"))
elsocim = vegrng.Address 'megjegyezzük a címét, mert itt kell leállítani
Do While Not vegrng Is Nothing
'megkeressük a kezdő sort
Set kezdrng = ws1.Columns("G").Find(what:="Titel", LookIn:=xlValues, lookat:=xlWhole, after:=vegrng, searchdirection:=xlPrevious)
If kezdrng.Row < vegrng.Row Then 'ha kisebb mint az S. Titel helye, akkor összeadjuk
vegrng.Offset(0, -1).Formula = "=Sum(" & kezdrng.Offset(1, -1).Address & ":" & vegrng.Offset(-1, -1).Address & ")"
End If
'következő S. Titel
Set vegrng = ws1.Columns("G").Find(what:="S. Titel", LookIn:=xlValues, lookat:=xlWhole, after:=vegrng, searchdirection:=xlNext)
If vegrng.Address = elsocim Then Exit Do 'ha visszaértünk az elsőhöz, kilépünk
Loop
'megkeressük az első S. Gewerk cellát:
Set vegrng = ws1.Columns("G").Find(what:="S. Gewerk", LookIn:=xlValues, lookat:=xlWhole, searchdirection:=xlNext, after:=Range("G1"))
elsocim = vegrng.Address: Set gewerkrng = Range("G1") 'megjegyezzük a helyét és a lehetséges első cellát
Do While Not vegrng Is Nothing
'megkeressük az első S. Titelt a Gewerkben
Set kezdrng = ws1.Columns("G").Find(what:="S. Titel", LookIn:=xlValues, lookat:=xlWhole, after:=vegrng, searchdirection:=xlPrevious)
Set celrng = kezdrng
Do While Not kezdrng Is Nothing
If kezdrng.Row > gewerkrng.Row Then ' ha benne van a tartományban
If kezdrng.Row < vegrng.Row Then ' és oda tartozik, akkor bevesszük az összesítésbe
Set celrng = Union(kezdrng, celrng)
Else
vegrng.Offset(0, -1).Formula = "=Sum(" & celrng.Offset(0, -1).Address & ")" 'ha nincs benne, akkor beírjuk az összesítő képletet
Exit Do
End If
Else
vegrng.Offset(0, -1).Formula = "=Sum(" & celrng.Offset(0, -1).Address & ")" ' ha már az előző Gewerkhez visszaértünk, akkor beírjuk az összesítő képletet
Exit Do
End If
'megkeressük a következő S. Titel cellát:
Set kezdrng = ws1.Columns("G").Find(what:="S. Titel", LookIn:=xlValues, lookat:=xlWhole, after:=kezdrng, searchdirection:=xlPrevious)
Loop
Set gewerkrng = vegrng ' a Gewerk területet változtatjuk
'megkeressük a következő S. Gewerk cellát:
Set vegrng = ws1.Columns("G").Find(what:="S. Gewerk", LookIn:=xlValues, lookat:=xlWhole, after:=vegrng, searchdirection:=xlNext)
If vegrng.Address = elsocim Then Exit Do 'ha visszaértünk az első találathoz, akkor végeztünk
Loop
MsgBox "A képleteket beírtam!", vbInformation
End SubElőször összesíti az S. Titel cellákhoz az adatot, majd az S Gewerk cellákét csinálja meg.
Remélem, jól fog működni, ha gond lenne, írj lsz.
Üdv.
-
Fferi50
Topikgazda
-
bsasa1
csendes tag
válasz
Declare
#32669
üzenetére
Szia,
volt egy hasonló makróm, kicsit átírtam. Nem pontosan úgy működik, mint a másik, de lehet, hogy segít. Illetve ennek is működnie kell nálad.
Sub reszosszeg()
Dim sor As Integer, darab As Integer, elozoertek As Integer, p As Integer, i As Integer
darab = WorksheetFunction.CountIf(Range("G:G"), "S. Gewerk")
sor = 1
elozoertek = 0
For i = 1 To darab
Set myfind = Range("G:G").Find(what:="S. Gewerk", LookIn:=xlValues, lookat:=xlWhole, searchdirection:=xlNext, after:=Range("G" & sor))
sor = myfind.Row
Range("F" & sor).FormulaR1C1 = "=Sumif(R2C[1]:R[-1]C[1],""S. Titel"",R2C:R[-1]C)"
p = Range("F" & sor).Value
Range("F" & sor).Value = Range("F" & sor).Value - elozoertek
elozoertek = p
Next i
End Sub -
Fferi50
Topikgazda
válasz
Declare
#32663
üzenetére
Szia!
"ilyenkor az ertek nem törlödik, hanem kicserelödik egy szóközre"
A Replace függvény Replacement paraméterét két idézőjelnek ("") kell megadni és nem idézőjelek között szóköznek!!! A két idézőjel az adott értéket üres stringre (semmire) cseréli.
Ebben az esetben viszont az Üres() függvény igaz értéket ad vissza a cellára.Üdv.
-
Fferi50
Topikgazda
válasz
Declare
#32634
üzenetére
Szia!
Kicsit nem értem a kérdést. A Range.Find metódussal a cellák tartalmára tudsz keresni, nem a nevükre... Jelen esetben azokat a cellákat keresi, amelyeknek a tartalma "Position". Egyszerre csak egy tartalmat tudsz keresni - de a további paraméterek függvényében ez lehet a cella képletében, megjegyzésében vagy az értékében (LookIn), ill. a cella egész értékét vagy egy részét keresi (LookAt).
Az újabb szöveg keresését ismételten el kell indítani.
Figyelem, a LookIn és a LookAt paraméterek értéke "öröklődik" - ugyanúgy, mint az Excelben a Ctr+F keresésnél.
Üdv.
-
Fferi50
Topikgazda
válasz
Declare
#31884
üzenetére
Szia!
Közben megszületett az új verzió:
Sub FormatText2()
Dim i As Double, mycell As Range, myfind As Range, elso As String
Set myfind = Range("H:H").Find(what:="w", LookIn:=xlValues, lookat:=xlWhole, searchdirection:=xlNext)
If Not myfind Is Nothing Then
elso = myfind.Address
Do While True
Set mycell = Range("H:H").Find(what:="p", LookIn:=xlValues, lookat:=xlWhole, searchdirection:=xlPrevious, after:=myfind)
If Not mycell Is Nothing Then
i = myfind.Row
With Range("A" & i & ":H" & i)
.Font.Name = "Calibri"
.Font.FontStyle = "Italic"
.Font.Underline = xlUnderlineStyleSingle
End With
Range("E" & i).Value = Range("A" & i).Value & " " & Range("D" & i).Value
Range("E" & i).HorizontalAlignment = xlRight
Range("A" & i & ":D" & i).ClearContents
Range("F" & i).Formula = "=Sum(" & Range("F" & i - 1).Address & ":" & Range("F" & mycell.Row).Address & ")"
End If
Set myfind = Range("H:H").Find(what:="w", LookIn:=xlValues, lookat:=xlWhole, searchdirection:=xlNext, after:=myfind)
If myfind.Address = elso Then Exit Do
Loop
End If
End SubEnnek az az előnye, hogy nem kell végigpörgetni az összes cellát, hogy megtaláld a w betűket, ezt rá kell bízni az Excelre - azért találták ki.
Feltétlenül fontos, hogy az első csoportösszesítés kezdetéhez is tegyél egy p betűt.Üdv.
-
Fferi50
Topikgazda
válasz
Declare
#31884
üzenetére
Szia!
Menni fog, csak egy pici türelmedet kérem, mert most éppen mással foglalkozom.
Addig is próbálj annyit ki, hogy az első összesítendő csoport elé is tegyél egy p betűt a h oszlopba (kb. 12 sor) és ezt a sort másold be a régi helyére: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, After:=Range("H" & Selection.Row)).Row).Address & ")"Annyi változott, hogy bekerült az After paraméter.
Üdv.
Ps: a ciklusod helyett egy find metódus használata sokkal gyorsabb lenne, ezt is próbálom majd.
-
Fferi50
Topikgazda
válasz
Declare
#31864
üzenetére
Szia!
Akkor "csak" annyi a gond, hogy a feltételben a "p" helyett "w" amit be kell írni:
Csak az eleje változik:
If Range("H" & Selection.Row).Value = "w" then stb.Mivelhogy eddig a w csak érintőlegesen szerepelt. Hiba esetén
If Err <> 0 Then If Range("H" & i).Value = "p" Then Range("F" & i).Value = Application.Sum(Range("F" & i - 1, Cells(1, "F")))
helyett is nyilván képletet szeretnél:If Err <> 0 Then If Range("H" & i).Value = "w" Then Range("F" & i).Formula = "=Sum(" & Range("F" & i - 1, Cells(1, "F")).Address & ")"Üdv.
-
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.
-
Plero
aktív tag
válasz
Declare
#31868
üzenetére
Megcsináltam a "Nyomtatás" gombot hozzárendeltem ezeket:
Sub Nyomtatas()
ActiveWorkbook.RefreshAll 'Frissiti az excel munkafüzetet /kihagyhato/
With ActiveSheet.PageSetup '/lap elrendezes/
.Orientation = xlLandscape
.CenterHorizontally = True
.CenterVertically = False
.PaperSize = xlPaperA4
End With
With ActiveSheet.PageSetup '/ egy lapra illeszti a nyomtatast + a lablecbe beteszi a lapszamot
.FitToPagesWide = 1
.RightFooter = "Seite &P/&N"
End With
Application.Dialogs(xlDialogPrinterSetup).Show '/nyomtato beallitas ablak
ActiveSheet.PageSetup.PrintArea = "$AU$1:$BI$22" '/nyomtatasi terület
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, Preview:=True, _
IgnorePrintAreas:=False
Range("K3") = Range("K3") + 1
End Subde nem csinál semmit és hibaüzenet sincs.
A K3 cellában sem növekszik a szám. -
Fferi50
Topikgazda
válasz
Declare
#31861
üzenetére
Szia!
Íme a képletet beíró sor:
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 & ")"Üdv.
-
Delila_1
veterán
válasz
Declare
#31858
üzenetére
Sub Beszur()
Selection.EntireRow.Insert
Rows(Selection.Row - 1).EntireRow.Copy Range("A" & Selection.Row)
Cells(Selection.Row, "K") = "=M" & Selection.Row - 1 & "*0.1"
End SubBemásolod modulba a makrót.
A Gyorselérési eszköztár jobb szélén katt a lefelé nyílra, További parancsok.
A "Választható parancsok helye" legyen Makrók. Az alatta lévő listából a Beszur nevűt átmásolod a jobb oldali listába. Ott a Módosítás gombbal rendelhetsz hozzá csilli-villi képet, megváltoztathatod a hozzá rendelt, megjelenő szöveget. -
Delila_1
veterán
válasz
Declare
#31856
üzenetére
A lap moduljába másold a makrót (lásd a Téma összefoglalót).
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
Selection.EntireRow.Insert
Rows(Target.Row - 2).EntireRow.Copy Range("A" & Target.Row - 1)
Cells(Target.Row - 1, "K") = "=M" & Target.Row - 2 & "*0.1"
End SubJobb klikkre indul.
Ugyanez duplaklikkhez:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)b
Cancel = True
Selection.EntireRow.Insert
Rows(Target.Row - 2).EntireRow.Copy Range("A" & Target.Row - 1)
Cells(Target.Row - 1, "K") = "=M" & Target.Row - 2 & "*0.1"
End Su -
Declare
őstag
válasz
Declare
#31855
üzenetére
jajj, pici modositas....rosszul irtam...pont ez a bajom....
szoval amit leirtam az csak egy pelda arra, amikor mondjuk az excel 10-ik soraban all a kijelöles. Nekem ugye az kellene, hogy ez mindig müködjön es mindig az eppen aktualis sor föle szurja be az uj sort, masolja az eggyel fölötte levö sort es a keplet "
=M9*0,1is mindig az eppen aktualisan beszurt sor fölötti M cellaja szorozva 0,1 el (szoval ha epp a 120-ik sorban beszur egy uj sort a makro, akkor ennek a sornak az M cellajaba (M120)=M119*0,1kerüljön.Bocs ha kicsit hosszu, de belezsibbadtam picit ebbe
es pont ez a bajom, ez az aktualis sor dolodg 
-
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
Declare
#31524
üzenetére
Néhány megjegyzés:
A makró címének ne adj VBA kulcsszót (copy).
Deklaráltál egy MyCol változót, amit később nem használsz fel (apró dolog, nagyobb baj lenne fordítva).
A for-next ciklusnál alapérték az 1-es lépésköz, ezért nem kell kiírni.
Ha az A oszlop utolsó értéke >=13, akkor a másolt E13:AB14 tartomány felülírja a vizsgált H oszlop értékét.
Nincs szükség a függvényre, hiszen 1 cella értékét vizsgálod, nem egy tartományét.Sub Masolas()
Dim i As Integer
For i = 1 To Range("A1353").End(xlUp).Row
If Range("H" & i) = "1" Then Range("E13:AB14").Copy Range("E" & i)
Next i
End Sub -
Declare
őstag
válasz
Declare
#31523
üzenetére
Megvan
nem er nevetni Sub copy()
Dim MyCol As String
Dim i As Integer
For i = 1 To Range("A" & "1353").End(xlUp).Row Step 1
If Application.WorksheetFunction.CountIf(Range("H" & i & ":H" & i), "1") > 0 Then
Range("E13:AB14").copy Range("E" & i & ":AB" & i + 1)
End If
Next i
End Subha esetleg van egyszerübb megoldas es van valakinek ideje/kedve leirni, szivesen olvasnam el ettöl függetlenül, hogy ez most müxik
-
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 -
Nowitzki
csendes tag
válasz
Declare
#31160
üzenetére
Szia,
Próbáld meg ezt:
Sub ActiveSheetExportToPdf()
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1)) & "_Laserteileliste" & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End Sub -
bteebi
veterán
-
Fferi50
Topikgazda
válasz
Declare
#27242
üzenetére
Szia!
Próbáld meg ezt a képletet:
lastline=Range("A353",Range("A" & rows.count).End(xlUp)).find(what:=" ",lookin:=xlvalues,lookat:=xlwhole,searchdirection:=xlnext).row-1Ez az A353 cellától lefelé megkeresi az első olyan cellát, amelynek az értéke egy db szóköz (" ") és az azt megelőző cella sorát adja vissza.
" Ha pl egy HA fv. eredmenye ez: " " akkor a ra hivatkozo keplet (pl egy FKERES) ennel a sornal siman csak nem csinal semmit"
Ez a simán nem csinál semmit, azt jelenti, hogy felveszi a szóköz értékét szerintem.A hibás eredmény visszaadását kétféle módon is kezelheted:
Létezik a HIBÁS függvény, amit a HA függvénnyel kombinálva megadhatod, hogy hiba esetén milyen értéket adjon vissza a képlet. Ez annyiban macerás egy kicsit, hogy az igaz ágon meg kell ismételni a képletet: Pl. HA(HBÁS(Fkeres(A1;B1:B100;1;0));0;Fkeres(A1;B1:B100;1;0)) megoldás hiba esetén 0 értéket ad vissza, egyébként pedig a megtalált értéket. Ez minden excelben benne van.2010-es exceltől már biztosan van (lehet 2007-től is) a HAHIBA (iferror) függvény, amelynél már nem kell megismételni a képletet: HAHIBA(Fkeres(A1;B1:B100;1;0);0) ugyanazt az eredményváltozatot adja, mint a fenti képlet.
Üdv.
-
Fferi50
Topikgazda
válasz
Declare
#27236
üzenetére
Szia!
1. Használd légy szíves a programkód vagy a konvertálatlan gombokat a keret alján, hogy ne a "fejecskék" jöjjenek elő, mert így nem lehet tudni, hogy mit írtál be (bár gondolom :F lett volna)
2. A LastLine változónak elvileg azt az utolsó sort kellene visszaadnia, amelyben még érték van és nem képlet. Viszont, ha a képlet eredményeként nem üres sztring ("") kerül oda, akkor azt fogja érzékelni értéknek. Ha például szóköz (" ") van ott, akkor sajnos (vagy természetesen) az már valódi értéknek minősül (és gyanús ez nekem a makró módosításod miatt.)
Szerintem a képletedet kellene úgy módosítani, hogy ne " " legyen, hanem "" a cella értéke, ha nincs valódi érték.Üdv.
-
be.cool
csendes tag
válasz
Declare
#27237
üzenetére
Szia!
Köszönöm a válaszodat. Az baj,hogy másolni kell a cellákat utána és behelyezni egy másik programba.
Szöveggé alakítottam a cellákat és utána már be tudok írni hosszabb számsorokat.(gondolom így viszont számolni nem lehetne vele, de erre most szerencsére nincs szükség
) -
-
-
-
![;]](http://cdn.rios.hu/dl/s/v1.gif)
es pont ez a bajom, ez az aktualis sor dolodg 
nem er nevetni 
Új hozzászólás Aktív témák
Hirdetés
Fferi50- Audi, Cupra, Seat, Skoda, Volkswagen topik
- Intel Core i3 / i5 / i7 / i9 10xxx "Comet Lake" és i3 / i5 / i7 / i9 11xxx "Rocket Lake" (LGA1200)
- Kerékpárosok, bringások ide!
- Milyen belső merevlemezt vegyek?
- Motorolaj, hajtóműolaj, hűtőfolyadék, adalékok és szűrők topikja
- Fotók, videók mobillal
- Le Mans Ultimate
- AMD K6-III, és minden ami RETRO - Oldschool tuning
- Xbox Series X|S
- Battlefield 4
- További aktív témák...
- Bitdefender Total Security 3év/3eszköz! - Tökéletes védelem, Most kedvező áron!
- Kaspersky, McAfee, Norton, Avast és egyéb vírusírtó licencek a legolcsóbban, egyenesen a gyártóktól!
- Adobe Előfizetések - Adobe Creative Cloud All Apps - 12 Hónap - NYÁRI AKCIÓ!
- Windows, Office licencek kedvező áron, egyenesen a Microsoft-tól - Automata kézbesítés utalással is!
- Új, bontatlan World of Warcraft gyűjtői kiadások
- Beszámítás! Apple Mac mini 2023 M2 Pro 16GB 512GB SSD számítógép garanciával, hibátlan működéssel
- Vidd haza a jövő RAM-ját már ma!
- ÁRGARANCIA!Épített KomPhone i5 13400F 16/32/64GB RAM RX 7700 XT 12GB GAMER PC termékbeszámítással
- AKCIÓ! ASUS MAXIMUS VIII HERO Z170 chipset alaplap garanciával hibátlan működéssel
- DELL PowerEdge R730xd 12LFF rack szerver - 2xE5-2680v3,64GB RAM,4x1GbE,H330 RAID v ZFS
Állásajánlatok
Cég: CAMERA-PRO Hungary Kft
Város: Budapest
Cég: Promenade Publishing House Kft.
Város: Budapest