Hirdetés
-
GAMEPOD.hu
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
-
-
Fferi50
Topikgazda
válasz
ny.erno
#47853
üzenetére
Szia!
Azért remélem, hogy az Excel által talált duplikáció az igazi.
Persze ne feledjük, hogy az 123 szöveg és a 123 szám az nem egyforma az Excelben, ebből lehet eltérés.
Gondolom, a sorozatszámaidban betű is van és akkor nem játszik az előző megjegyzésem.
Üdv.
Ps. Remélem, könnyebb lesz az életed vele. -
#47857
Darko_addict
őstag
Darko_addict
őstag
Sziasztok!
Egy látszólag egyszerű probléma megoldásához kerestem képletet.
Adott egy 30-31 értékes sor, ami utolsó 5 értékének az átlagát szeretném kiíratni.
Ezek a hónap napjait jelölik, minden nap új érték kerül felvitelre az aktuális nap alá, mely lehet 0, bármilyen más szám vagy maradhat üresen is.
Elsősorban szerettem volna kitalálni, hogyan lehet képletbe foglalni azt, ha mindig van érték. Az üressel vagy nullával bonyolításig el sem jutottam (egyelőre nem tudom, hogy a nullát bele akarom-e venni vagy tekintsen rá "üresként"), valamint ahhoz sem tudtam ezáltal hozzászagolni, hogy kezelje azt a helyzetet, mikor kevesebb, mint 5 érték van a sorban.Feltöltöttem a Teszt munkafüzetet ide: [Google Drive], és csatolok képernyőmentést is: [kép].
A probléma az, hogy ha a legelső, ha az utolsó cella értékeit módosítom, az hatással van az átlagra, ami az egésznek a lényegét dönti romba. Akkor találtam és implementáltam olyan egyenletet, ami egy sor üres cellára is értéket hozott. Olyat, ami ugyanezekre a számokra 40.000 feletti eredményt mutatott, de ezt módosítva sikerült elérni, hogy egész számokból képtelen törtek legyenek...Tudnátok adni iránymutatást? Google-ben kerestem megoldásokat, de némelyik túlontúl bonyolultnak tűnt.
Otthon: Windows 10, Professional Plus 2019
Munkahelyen: Windows 10, Office 2016 - mindkettő magyar nyelvűKöszönöm szépen!
Don't give up your dreams. Keep sleeping.
-
#47858
lappy
őstag
Darko_addict
#47857
lappy
őstag
-
Fferi50
Topikgazda
válasz
ny.erno
#47856
üzenetére
Szia!
Íme:Sub valogato()
Dim a, x As Long, y As Long, u As String, d, v As String
ActiveSheet.UsedRange.Columns("A").Copy Range("D1")
y = ActiveSheet.UsedRange.Rows.Count
Debug.Print "sort indul:" & Time
With Range("D1:D" & y)
.Sort key1:=Range("D1"), Header:=xlNo
Debug.Print "sort vége:" & Time
a = .Value
End With
u = ""
Debug.Print "Keresés indul: " & Time
d = ""
For x = 1 To y - 1
If a(x, 1) = a(x + 1, 1) Then
If d = "" Then
u = u & ";" & a(x, 1): d = a(x, 1)
Else
If a(x + 1, 1) <> d Then u = u & ";" & a(x, 1): d = a(x, 1)
End If
Else
If a(x, 1) <> d Then v = v & ";" & a(x, 1)
End If
DoEvents
If x Mod 1000 = 0 Then Application.StatusBar = "Készen van eddig " & x
Next
If a(x, 1) <> d Then v = v & ";" & a(x, 1)
Debug.Print "Keresés vége:" & Time
u = Mid(u, 2): v = Mid(v, 2)
a = Application.Transpose(Split(u, ";"))
Range("M1:M" & UBound(a)).Value = a
a = Application.Transpose(Split(v, ";"))
Range("F1:F" & UBound(a)).Value = a
Debug.Print "Visszaírás vége: " & Time
Application.StatusBar = False
MsgBox "Készen vagyunk"
End Sub
Az F oszlopba írja ki az ismétlődés nélküli értékeket.
Üdv. -
Fferi50
Topikgazda
válasz
ny.erno
#47856
üzenetére
Szia!
Közben találtam egy makró nélküli megoldást is, de ehhez pár műveletet el kell végezni :
1. Legyen az A oszlopnak fejléce - mondjuk Sorozatszám
2. Beszúrás - kimutatás - új lapra
Sorozatszám mező a Sorokhoz
Sorozatszám mező az Érték területre - mennyiség Sorozatszám
Elfogadható időn belül kész a kimutatás!
3. Az egész kimutatást a végösszeg sor nélkül kijelölni - beillesztés értéket egy új területre az új lapon.
4. Szűrő bekapcsolása az átmásolt adatokra
5. Szűrő - csak az 1 bekapcsolva - az egyedi értékek lesznek. Sorozatszám másolás - irányított beillesztés értéket - oda, ahol látni szeretnéd az egyedi sorozatszámokat
6. Szűrő - átállítás az 1 kivételével minden - az ismétlődő értékek maradnak. Sorozatszám másolás - irányított beillesztés - oda, ahol az ismétlődéseket szeretnéd látni.
Kétszázezer sorral kevesebb ideig tartott, mint ide leírni!
Persze usert ilyenre kérni nem lehet, tesztelem a hozzá kapcsolódó makrót, ha kész lesz felmásolom.
Üdv. -
ny.erno
tag
válasz
Fferi50
#47859
üzenetére
Szia!
Megnéztem, az egyedi értékeket 980 egyedi értékig gyűjti ki (~135k helyett), de késznek tekinti, nincs hibakód.
Egyébként plusz érdekesség, hogy a NotePad++-szal megszűrt listát (kódolás UTF-8) másolok be excelbe és azon a listán futtatom a makrót, akkor az alábbi hibát dobja befejezés előtt: Run-time error '13': Type mismatch
Ha ugyan ezt a Notapad++ listát jegyzettömbe másolom és onnan excelbe, akkor megint másik hibakód jön: Run-TIme Error '1004': Method 'StatusBar' of object '_Application' failed.
Ide tettem a fájlokat, amin próbálgatom a lehetőségeket.
Eredeti excel makró eredmény: 135.531 egyedi érték
NotePad++ eredmény: 135.521 egyedi érték
Scrapebox eredmény: 135.020 egyedi érték -
Fferi50
Topikgazda
válasz
ny.erno
#47863
üzenetére
Szia!
Én az egyik futásnál ellenőriztem, hogy megvan-e mind a kétszázezer szám (ismétlődések összeadva + az egyedi) pontosan megvolt.
A pivottáblás makró, feltételek:
Első futtatásnál:
Csak 1 munkalap legyen a munkafüzetben, amelyiknek az A oszlopában ott vannak a számok. A1 cella fejléc.
Ekkor a makró létrehoz egy nevet - forras - a névkezelőben, ami beállítja a pivot forrását
Ezután létrehoz egy új munkalapot, arra a pivottáblát.
Az új D1 cellájától kezdve átmásolja a pivot eredményét.
Szűri 1 -re (azaz egyediek) - átmásolja az első munkalap D oszlopába
Szűri >1-re (azaz ismétlődők) - átmásolja az első munkalap F oszlopába
Ez kb. fél perc 200000 tételnél.
Ha a továbbiakban a változások kezelésére is ezt szeretnéd használni, akkor nincs más teendő, mint az új sorozatszámokat hozzáírni/felülírni az első munkalap A oszlopában, majd jöhet a
második/sokadik futtatás
Fontos! Ebben az esetben is az első munkalapon kell állnod, amikor a makrót indítod.
Az előző futás eredménye felülíródik a D és F oszlopokban.
Íme a makró:Sub tablas()
Dim sh1 As Worksheet, sh2 As Worksheet, pvt As PivotTable, tblsource As String, pvtfname As String, nm As Name
Application.ScreenUpdating = False
Set sh1 = ActiveSheet: pvtfname = sh1.Range("A1").Value
If Names.Count > 0 Then
Set nm = Names("forras")
End If
If nm Is Nothing Then Set nm = ActiveWorkbook.Names.Add(Name:="forras", RefersTo:="=OFFSET(" & sh1.Name & "!$A$1,0,0,COUNTA(" & sh1.Name & "!$A$1:$A$300000),1)")
If Sheets.Count = 1 Then
Set sh2 = ActiveWorkbook.Sheets.Add(after:=sh1)
Else
Set sh2 = Sheets(2)
End If
tblsource = Replace(Evaluate(Names("forras").RefersTo).Address(ReferenceStyle:=xlR1C1, external:=True), "[" & sh2.Parent.Name & "]", "")
If sh2.PivotTables.Count = 0 Then
Set pvt = sh1.Parent.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=tblsource, Version:=6).CreatePivotTable(tabledestination:=Replace(sh2.Range("A1").Address(ReferenceStyle:=xlR1C1, external:=True), "[" & sh2.Parent.Name & "]", ""), TableName:="Srszamok", Defaultversion:=6)
pvt.AddDataField pvt.PivotFields(pvtfname), "Darabszám", xlCount
pvt.PivotFields(pvtfname).Orientation = xlRowField
Else
Set pvt = sh2.PivotTables(1)
pvt.RefreshTable
End If
With sh2.Range("D1")
If .Value <> "" Then .CurrentRegion.ClearContents
If sh1.Range("D1").Value <> "" Then sh1.Range("D1").CurrentRegion.ClearContents
If sh1.Range("F1").Value <> "" Then sh1.Range("F1").CurrentRegion.ClearContents
.Resize(rowsize:=pvt.TableRange1.Rows.Count, columnsize:=pvt.TableRange1.Columns.Count).Value = pvt.TableRange1.Value
With .CurrentRegion
.AutoFilter field:=2, Criteria1:="1"
.Columns(1).SpecialCells(xlCellTypeVisible).Copy Destination:=sh1.Range("D1")
.AutoFilter field:=2, Criteria1:=">1"
.Columns(1).SpecialCells(xlCellTypeVisible).Copy Destination:=sh1.Range("F1")
.AutoFilter field:=2
End With
End With
sh1.Range("D1").Value = "Egyedi": sh1.Range("F1").Value = "Ismétlődő"
sh1.Activate
ActiveWindow.ScrollRow = 1
Range("D1").Select
MsgBox "Készen vagyunk!"
Application.ScreenUpdating = True
End Sub
Üdv. -
Hintalow
senior tag
Sziasztok,
Ha van egy oszlopban egy adag számom, hogy tudom megoldani, hogy pontokkal legyenek elválasztva hármas csoportonként? Mert ha számformátumba állítom, akkor a szeparátor betesz szóközöket közéjük, addig oké, de nekem nem szóköz kéne oda, hanem pont karakter.
Ráadásul amit a szeparátor csinál, az nem is igazi szóköz, mert a replace all parancsal sem tudom kicserélni őket, szerinte nincs ott semmilyen szóköz. (ebből ered a probléma is, amiért pontot akarnék, mivel körlevélbe kellenének a számok, és ahogy oda behúzza az adatokat, mivel nem igazi szóköz, már egybe teszi az összes számot)Ha a multiverzum teória igaz, akkor van egy univerzum, ahol nem az.
-
Hintalow
senior tag
Köszönöm, próbálkozom, bár úgy tűnik ez fixen tesz be annyi karaktert pozíciókra, amennyi be van írva, és persze nekem változó hosszúságú számértékek vannak (százezres,milliós,tízmilliós) így nem mindig ugyanannyi karakterhosszal kell dolgozni, ha ez nem lenne elég
Fferi50: köszi, megnézem azt is
[ Szerkesztve ]
Ha a multiverzum teória igaz, akkor van egy univerzum, ahol nem az.
-
ny.erno
tag
válasz
Fferi50
#47864
üzenetére
Szia!
Profi, MŰKÖDIK!!!
Tesztelgetem különböző listákkal, de szerintem rendben lesz. Nálam új értékekek hozzáadása után, futtatás előtt ki kell törölnöm a másik munkalapot, plusz az első munkalapon a kilistázott egyedi és ismétlődő értékeket. De ez a három kattintás semmiség, szóval mégegyszer köszönöm! 
-
Fferi50
Topikgazda
válasz
ny.erno
#47869
üzenetére
Szia!
If Sheets.Count = 1 Then
Set sh2 = ActiveWorkbook.Sheets.Add(after:=sh1)
Else
Set sh2 = Sheets(2)
End If
Ez a rész akkor ad hozzá új munkalapot, ha csak egy lap van a munkafüzetben. Ha több, akkor a második munkalapot használja - amin elvileg az első futás után a pivot keletkezik.
Ugye első futás előtt követelmény, hogy csak 1 munkalap legyen a füzetben, így a futáskor létrehozott munkalap lesz a második.
Ismételt futás után már nem kell a pivotot létrehozni, az ott van a második munkalapon, csak aktualizálni kell.If .Value <> "" Then .CurrentRegion.ClearContents
If sh1.Range("D1").Value <> "" Then sh1.Range("D1").CurrentRegion.ClearContents
If sh1.Range("F1").Value <> "" Then sh1.Range("F1").CurrentRegion.ClearContents
Ez a 3 sor törli a második munkalap D1-es területét és az első munkalap D1 és F1 oszlopát.
Szerintem nem lenne szükség törlésre.
Mi miatt volt nálad a külön törlésekre szükség?
Üdv. -
ny.erno
tag
válasz
Fferi50
#47870
üzenetére
Szia!
A folyamat lassabb lett, valamint ha hozzáadtam az A oszlopba folytatólagosan sorozatszámokat, akkor a második munkalapon alul ahol összesíti a darabszámot, az összegnél az tűnt fel, hogy az eredetileg a táblában szereplő összeg van. Próbáltam mindkét lapon frissíteni az adatokat és úgy lefuttatni, de ugyan az volt az eredmény. -
eszgé100
őstag
Én is darabtelivel szórakozok:
B1 képlete: =IF(COUNTIF(A1:A$7,A1)>1,"yes","no")
A vastaggal kiemelt részt hogyan tudnám változtatni annak függvényében, hogy beviszek-e újabb adatot A8-ba?
Valami hasonlóra gondolok:
=IF(COUNTIF(A1:A&lastrow,A1)>1,"yes","no")Egyszer már véletlenül kigugliztam, de ma az istenért sem találom.
"-Meddig tart a játék? -Amíg mindenkinek ki nem verik a fogát..."
-
eszgé100
őstag
válasz
Pakliman
#47875
üzenetére
Nagyon szepen koszonom, ez lesz egyelore a befuto, meg kell meg neznem, hogy nagyobb cellatartomanyon nem-e okoz lassulast
lappy es Fferi50 koszonom nektek is, nem gondoltam, hogy ilyen keson meg valaki reagal "-Meddig tart a játék? -Amíg mindenkinek ki nem verik a fogát..."
-
-
eszgé100
őstag
válasz
Delila_1
#47877
üzenetére
Köszönöm, de nem pontosan ilyen formában kerestem a duplikációt.
Van egy vba ciklusom, fentről lefelé halad, ezért nem releváns, hogy a tartomány felső részében található-e a duplikáció, lényeg, hogy a maradékban ne legyen, erre tökéletes volt Pakliman formulája, szerencsére működik ez is automatikusan, ha táblává alakítom. egyébként örök hálám az ötletért, megmentettél egy kör guglizástól Valós felhasználása egyébként az lesz, hogy B oszlopban lesznek elérési útvonalak, többi oszlopban különböző paraméterek a ciklusnak, és az utolsó oszlopban lesznek tárolva a válaszok a Save&Close-ra. Ha az adott fájlt később még használja a ciklus, akkor nyitva hagyom (válasz no), ha nem akkor mentés és zárás (yes), példában pont fordítva kérdeztem, de az már csak részletkérdés.
Ezzel kapcsolatban meg is érkeztem ma esti fejtörőmhöz:
Ciklusomban egy bizonyos ponton elérkezek a nyomtatáshoz
Select Case CStr(printer)
Case "col"
Application.ActivePrinter = col
tp.PrintOut copies:=CStr(copies)
Case "bw"
Application.ActivePrinter = bw
tp.PrintOut copies:=CStr(copies)
Case Else
MsgBox "No printer selected"
End SelectMajd ezután megvizsgálom, hogy Save&Close "yes"-e?
If CStr(saveandclose) = "yes" Then
Excel.Workbooks(fileName).Close SaveChanges:=True
Else: GoTo nextraw
End If
Itt kezdődnek a bajok, a kettő közé kellene valami, ami megakasztja a cilkus további futását, amíg ez az ablak be nem záródik.
Ugyanis, ha várni kell a nyomtatóra valamiért, akkor az ciklus egyszerűen bezárja a fájlom még mielőtt el lett volna küldve a nyomtatóra.
Próbáltam ezt, wordben ok, de sajnos excelben nem működik:
While Application.backgroundPrintingStatus > 0
Application.Wait (Now + TimeValue("00:00:01"))
WendSimán Application.Wait-et sem akarok használni, mert akkor 1000 évig tartana, míg végez a ciklus, plusz azt sem tudom mennyi időt kellene pontosan meghatároznom.
"-Meddig tart a játék? -Amíg mindenkinek ki nem verik a fogát..."
-
Pakliman
tag
válasz
eszgé100
#47878
üzenetére
Szia!
Egy ilyen kódot találtam.
Nem tudom, műxik-e, nem próbáltam
Van benne egyJobsDesc(lThisJob).pDocumentsor a For .. Next ciklusban, talán a nyomtatandó file neve.(A saját programomban rákérdezek, hogy sikerült-e nyomtatás és csak azután megyek tovább. Bár nálam a nyomtatott dokumentum megléte és minősége a lényeg.)
Találtam mégy egyet, ami talán egy kicsit egyszerűbb(en átalakítható a Számodra).
[ Szerkesztve ]
-
eszgé100
őstag
válasz
Pakliman
#47879
üzenetére
Do While ActiveWindow.View = xlPrint
'Application.Wait (Now + TimeValue("00:00:01"))
LoopElőször Application.Wait-tel próbáltam, de még az is felesleges a boldogsághoz
Egyelőre csak itthon tudtam kipróbálni, majd hétfőn meglesem melóban is, hogy a valóságban is működik-e?[ Szerkesztve ]
"-Meddig tart a játék? -Amíg mindenkinek ki nem verik a fogát..."
-
eszgé100
őstag
válasz
Fferi50
#44543
üzenetére
"Nem tudom hány xls-ed van, de nem hiszem, hogy mindegyiket külön-külön el kellene látni ugyanazon funkciókat végző makrókkal. Én egy alap Excelt használnék, amiben a makrók benne vannak és abból intézném az összes többinek a megnyitását és kezelését. Így csak egy fájlt kell karbantartani, nem pedig x db-ot.
De lehet, hogy rosszul látom.
Üdv."Üdv Fferi50,
Nem láttad rosszul a dolgokat, jelenleg így állok a dologgal:
Ez a kód lefut megnyitáskor:
Option Explicit
Private Const HKEY_CURRENT_USER As Long = &H80000001
Private Const HKCU = HKEY_CURRENT_USER
Private Const KEY_QUERY_VALUE = &H1&
Private Const ERROR_NO_MORE_ITEMS = 259&
Private Const ERROR_MORE_DATA = 234
Private Declare PtrSafe Function RegOpenKeyEx Lib "advapi32" _
Alias "RegOpenKeyExA" ( _
ByVal HKey As Long, _
ByVal lpSubKey As String, _
ByVal ulOptions As Long, _
ByVal samDesired As Long, _
phkResult As Long) As Long
Private Declare PtrSafe Function RegEnumValue Lib "advapi32.dll" _
Alias "RegEnumValueA" ( _
ByVal HKey As Long, _
ByVal dwIndex As Long, _
ByVal lpValueName As String, _
lpcbValueName As Long, _
ByVal lpReserved As Long, _
lpType As Long, _
lpData As Byte, _
lpcbData As Long) As Long
Private Declare PtrSafe Function RegCloseKey Lib "advapi32.dll" ( _
ByVal HKey As Long) As Long
Public Function GetPrinterFullNames() As String()
Dim Printers() As String ' array of names to be returned
Dim PNdx As Long ' index into Printers()
Dim HKey As Long ' registry key handle
Dim Res As Long ' result of API calls
Dim Ndx As Long ' index for RegEnumValue
Dim ValueName As String ' name of each value in the printer key
Dim ValueNameLen As Long ' length of ValueName
Dim DataType As Long ' registry value data type
Dim ValueValue() As Byte ' byte array of registry value value
Dim ValueValueS As String ' ValueValue converted to String
Dim CommaPos As Long ' position of comma character in ValueValue
Dim ColonPos As Long ' position of colon character in ValueValue
Dim M As Long ' string index
' registry key in HCKU listing printers
Const PRINTER_KEY = "Software\Microsoft\Windows NT\CurrentVersion\Devices"
PNdx = 0
Ndx = 0
' assume printer name is less than 256 characters
ValueName = String$(256, Chr(0))
ValueNameLen = 255
' assume the port name is less than 1000 characters
ReDim ValueValue(0 To 999)
' assume there are less than 1000 printers installed
ReDim Printers(1 To 1000)
' open the key whose values enumerate installed printers
Res = RegOpenKeyEx(HKCU, PRINTER_KEY, 0&, _
KEY_QUERY_VALUE, HKey)
' start enumeration loop of printers
Res = RegEnumValue(HKey, Ndx, ValueName, _
ValueNameLen, 0&, DataType, ValueValue(0), 1000)
' loop until all values have been enumerated
Do Until Res = ERROR_NO_MORE_ITEMS
M = InStr(1, ValueName, Chr(0))
If M > 1 Then
' clean up the ValueName
ValueName = Left(ValueName, M - 1)
End If
' find position of a comma and colon in the port name
CommaPos = InStr(1, ValueValue, ",")
ColonPos = InStr(1, ValueValue, ":")
' ValueValue byte array to ValueValueS string
On Error Resume Next
ValueValueS = Mid(ValueValue, CommaPos + 1, ColonPos - CommaPos)
On Error GoTo 0
' next slot in Printers
PNdx = PNdx + 1
Printers(PNdx) = ValueName & " on " & ValueValueS
' reset some variables
ValueName = String(255, Chr(0))
ValueNameLen = 255
ReDim ValueValue(0 To 999)
ValueValueS = vbNullString
' tell RegEnumValue to get the next registry value
Ndx = Ndx + 1
' get the next printer
Res = RegEnumValue(HKey, Ndx, ValueName, ValueNameLen, _
0&, DataType, ValueValue(0), 1000)
' test for error
If (Res <> 0) And (Res <> ERROR_MORE_DATA) Then
Exit Do
End If
Loop
' shrink Printers down to used size
ReDim Preserve Printers(1 To PNdx)
Res = RegCloseKey(HKey)
' Return the result array
GetPrinterFullNames = Printers
End Function
Sub Auto_Open()
Dim start As Date
Dim weekcom As Date
Dim today As Date
start = Sheets("MainAssembly").Range("F3").Value
today = Sheets("MainAssembly").Range("F7").Value
weekcom = start
Do While weekcom < today
weekcom = weekcom + 28
Loop
Sheets("MainAssembly").Range("F6").Value = weekcom
Dim Printers() As String
Dim N As Long
Dim S As String
Dim col As String
Dim bw As String
Printers = GetPrinterFullNames()
For N = LBound(Printers) To UBound(Printers)
S = Printers(N) 'S & Printers(N) & vbNewLine
If InStr(S, "Microsoft") <> 0 And InStr(S, "Print") <> 0 Then col = S
If InStr(S, "HP Photosmart Wireless B109n-z") <> 0 And InStr(S, "Print") = 0 Then bw = S
Next N
Sheets("MainAssembly").Range("F8").Value = col
Sheets("MainAssembly").Range("F9").Value = bw
MsgBox col, vbOKOnly, "Colour Printer"
MsgBox bw, vbOKOnly, "BW Printer"
End SubEz pedig elvégzi a piszkos munkát:
Sub EOM_Main_Assy_Workbooks()
'loop:
Dim sPath As String, ssheet As String, fileName As String
Dim lastrow As Long, counter As Long
Dim ws As Worksheet, tp As Worksheet, ma As Worksheet
'printers:
Dim bw As String, col As String
'from main worksheet:
Dim sDate As String
Dim sWeek As String
Dim sWkcom As String
Dim nextmonth As Date
'from Table:
Dim freq As String
Dim area As String
Dim loc As String
Dim dat As String
Dim week As String
Dim wkcom As String
Dim procloc As String
Dim procname As String
Dim machloc As String
Dim machname As String
Dim printer As String
Dim copies As Integer
Dim saveandclose As String
sDate = "=[FillerPrinter.xlsm]MainAssembly!$F$4"
sWeek = "=[FillerPrinter.xlsm]MainAssembly!$F$5"
sWkcom = "=[FillerPrinter.xlsm]MainAssembly!$F$6"
Set ma = Workbooks("FillerPrinter.xlsm").Worksheets("MainAssembly")
nextmonth = ma.Range("F4")
col = ma.Range("F9")
bw = ma.Range("F9")
Set ws = Workbooks("FillerPrinter.xlsm").Worksheets("OpenClose")
lastrow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
counter = 2
Do While counter <= lastrow
ws.Activate
freq = Range("A" & counter)
area = Range("B" & counter)
loc = Range("C" & counter)
sPath = Range("D" & counter)
ssheet = Range("E" & counter)
dat = Range("F" & counter)
week = Range("G" & counter)
wkcom = Range("H" & counter)
procloc = Range("I" & counter)
procname = Range("J" & counter)
machloc = Range("K" & counter)
machname = Range("L" & counter)
printer = Range("M" & counter)
copies = Range("N" & counter)
saveandclose = Range("O" & counter)
'freq check
Select Case CStr(freq)
Case "4 weekly"
GoTo openworksheets
Case "monthly"
GoTo openworksheets
Case "2 monthly"
Select Case Month(nextmonth)
Case 1, 3, 5, 7, 9, 11
GoTo openworksheets
Case Else
GoTo nextraw
End Select
Case "3 monthly"
Select Case Month(nextmonth)
Case 1, 4, 7, 10
GoTo openworksheets
Case Else
GoTo nextraw
End Select
Case Else
GoTo nextraw
End Select
'open sheets
openworksheets:
Workbooks.Open sPath
fileName = Right(sPath, Len(sPath) - InStrRev(sPath, "\"))
'update sheets if necessary
Set tp = Workbooks(fileName).Worksheets(CStr(ssheet))
If CStr(dat) <> "" Then
Sheets(ssheet).Select
Range(dat).Select
ActiveCell.Formula = sDate
End If
If CStr(week) <> "" Then
Sheets(ssheet).Select
Range(week).Select
ActiveCell.Formula = sWeek
End If
If CStr(wkcom) <> "" Then
Sheets(ssheet).Select
Range(wkcom).Select
ActiveCell.Formula = sWkcom
End If
If CStr(procloc) <> "" Then
Sheets(ssheet).Select
Range(procloc).Select
ActiveCell.Formula = procname
End If
If CStr(machloc) <> "" Then
Sheets(ssheet).Select
Range(machloc).Select
ActiveCell.Formula = machname
End If
'print sheets
Select Case CStr(printer)
Case "col"
Application.ActivePrinter = col
tp.PrintOut copies:=CStr(copies)
Case "bw"
Application.ActivePrinter = bw
tp.PrintOut copies:=CStr(copies)
Case Else
MsgBox "No printer selected"
End Select
'wait here a bit
Do While ActiveWindow.View = xlPrint
Loop
'time to save&close
If CStr(saveandclose) = "yes" Then
Excel.Workbooks(fileName).Close SaveChanges:=True
Else: GoTo nextraw
End If
nextraw:
counter = counter + 1
Loop
Worksheets("MainAssembly").Select
Range("A1").Select
MsgBox "Done!"
End SubEz nem az összes workbook, amivel foglalkoznom kell, de egyelőre tesztnek elegendőek ezek is. Jelenlegi formájában a kód 88 sheetet kevesebb, mint 2 perc alatt megnyitott, update-elt, nyomtatóra küldött, majd bezárt
Már csak szűrést és hibakezelést kellene beleszőnöm valahogy.
Az egész csoportnak köszönöm mégegyszer az eddigi segítséget"-Meddig tart a játék? -Amíg mindenkinek ki nem verik a fogát..."
-
Delila_1
veterán
válasz
eszgé100
#47881
üzenetére
Gyorsíthatod a futást, ha nem állsz rá lépten-nyomon egyes cellákra. 5 ilyen feltételt láttam.
If CStr(dat) <> "" ThenSheets(ssheet).SelectRange(dat).SelectActiveCell.Formula = sDateEnd Ifhelyett írd ezt
If CStr(dat) <> "" Then Sheets(ssheet).Range(dat).Formula = sDateProgramozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.
-
eszgé100
őstag
válasz
Delila_1
#47882
üzenetére
Átírtam, kb 1 másodperc gyorsulast hozott, ami meg sokkal tobb is lesz, mire minden sor fel lesz toltve a tablaban. Azert irtam eredetileg igy, hogy minden lepest lathassak lebontva, mikot a step into-t hasznalom
"-Meddig tart a játék? -Amíg mindenkinek ki nem verik a fogát..."
-
zoombiee
csendes tag
Sziasztok,
Bár nem excel, hanem google sheet kérdés, de remélem azért maradhat.Szeretnék olyan megoldást, mint amit néhány weboldalon láttam:
Jobb klikk másol és ctrl+c tiltva van az adatok ellophatósága végett.Ez megolható google felületen, vagy csak html kódban működhet?
Segítséget előre is köszönöm!
Üdv: Dani -
cekkk
veterán
Sziasztok!
A DÁTUMTÓLIG fügyvényt szeretném használni, de nem találom az excelben.
Hogyan tudom megívni ezt a függvényt? -
Fferi50
Topikgazda
Szia!
Biztos, hogy dátum az amit ott kapsz? Szerintem szöveg, csak dátumnak gondolod.
Nézd meg a cellaformátumot légy szíves és próbáld átállítani számra.
Ha szám lesz belőle, akkor dátum és csak formátumot kell változtatni.
Ha marad ilyen, akkor szöveg és függvényekkel tudod dátummá alakítani segédoszlopban, pl.
=Dátum(jobb(A1;4);közép(A1;4,2);bal(A1;2))
Üdv. -
ReSeTer
senior tag
Helló!
Lehet olyat csinálni VBA-ban, hogy csinálok egy sablon kódsort, és azt behívom máshol ott megadott értékekkel?
Sablonkod()
A=
B=
Sor=
Oszlop=
Muvelet=A+BCell(Sor,Oszlop).Text=Muvelet
End Sablonkod
És akkor ezt így használnám egy másik kódban:
Masikprogram()
Call Sablonkod(A=4,B=8,Sor=1,Oszlop=3)
End Masikprogram
Bocs, tudom, hogy ez így nem helyes, még tanulom a VBA-t, de remélem a lényeg átjön.
Lehet ilyet csinálni? Valami olyat találtam, hogy egy funkció visszaad egy változót, de nekem nem kell, hogy visszaadjon bármit is, inkább csináljon valamit, mint pl fent, hogy átír egy cellát. -
Fferi50
Topikgazda
válasz
eszgé100
#47881
üzenetére
Szia!
Apróságokat tennék hozzá, talán gyorsít valamit rajta:
1. Kérdés: ahol Save&Close =no ott nem kell bezárni a fájlt? Mert ebben az esetben sok-sok fájlod nyitva fog maradni.
Ha mégis be kell zárni, akkorIf CStr(saveandclose) = "yes" Then
Excel.Workbooks(fileName).Close SaveChanges:=True
Else: GoTo nextraw
End If
helyett javaslom:Excel.Workbooks(fileName).Close SaveChanges:= CStr(saveandclose) = "yes"
Ha nyitva kell hagyni, akkor is elég az IF-es sor a következőképpen:If CStr(saveandclose) = "yes" Then Excel.Workbooks(fileName).Close SaveChanges:=True
Nem kell hozzá ELSE és END IF.
2. Javaslat: én nagyon nem szeretem az ugrálást makrón belül, általában mindig meg lehet oldani e nélkül a feladatot. Nálad 2 cimke van: openworksheets és nextraw.
Egy új változó bevezetésével el lehet kerülni a cimkéhez ugrást.
Dim nyomtatni As Boolean
Ennek a változónak adunk értéket a Select Case utasításokon belül - ezt is egy picit egyszerűsítve:Select Case CStr(freq)
Case "4 weekly", "monthly"
nyomtatni = True
Case "2 monthly"
nyomtatni = Month(nextmonth) Mod 2 = 1
Case "3 monthly"
nyomtatni = Month(nextmonth) Mod 3 = 1
End Select
A két cimke helyére pedig:openworksheets: helyett:
If nyomtatni Then
.
.
nextraw: helyett
End If
Áttekinthetőbb és szerintem gyorsabb is lehet.
3. Kérdés:
Milyen szűrést szeretnél? Hol lenne helye a hibakezelésnek?Üdv.
-
Czmorek
aktív tag
Sziasztok!
Az alábbi kérdéssel fordulnék hozzátok:
Egy oszlop értékeit összeadom egy cellában =SZUM(B1:B33)
Most én hozzá szeretném adni egy másik oszlop adatait is pl. az F és G oszlopét is (sorok számai ugyanazok)Egy másik:
Hogyan lehetne beállítani egy cellánál, hogy amíg nem éri el a pozitív értéket a számok mennyisége, addig ne jelenítsen meg negatív számot, hanem 0 legyen ott addig amíg nem ér pozitívba?
Köszönöm! -
Czmorek
aktív tag
-
ReSeTer
senior tag
Helló!
Fel lehet valahogy használni egy funkción belüli változót a főmakróban?
Function peldafunkcio (a as integer, b as integer) as integerpeldafunkcio=a+beztakaromfelhasznalni=a-bEnd FunctionSub fomakro()egyebvaltozo=valami+eztakaromfelhasznalniEnd SubEzt így nem lehet, mert üresen áll a "eztakaromfelhasznalni" váltózó miután visszatér a program a fomakro-ba.
sajnos.
Új hozzászólás Aktív témák
- BIOS frissítés
- Milyen notebookot vegyek?
- Befagy az egész gép
- Call of Duty: Black Ops 6
- Sorozatok
- Autós topik látogatók beszélgetős, offolós topikja
- Black Friday november 29. / Cyber Monday december 2.
- Filmvilág
- Milyen asztali (teljes vagy fél-) gépet vegyek?
- HDD probléma (nem adatmentés)
- További aktív témák...
Állásajánlatok
Cég: HC Pointer Kft.
Város: Pécs
Cég: PCMENTOR SZERVIZ KFT.
Város: Budapest