- iPhone topik
- Huawei Watch GT 6 és GT 6 Pro duplateszt
- One mobilszolgáltatások
- Google Pixel topik
- Xiaomi 14T Pro - teljes a család?
- Samsung Galaxy S23 és S23+ - ami belül van, az számít igazán
- Nem lesz iPhone 19
- Fotók, videók mobillal
- Milyen okostelefont vegyek?
- Samsung Galaxy A55 - új év, régi stratégia
-
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
-
#5948
Fire/SOUL/CD
félisten
Pulsar
#5946
Hali!
Ahhoz, hogy ezt megtehesd, az excel tábla útvonalából ki kell emelni a fájlnevet például. Az alábbi makró ezt teszi. (a fájl kiterjesztést törli) Aztán, hogy a kapott névvel új munkalapot hozol-e létre, vagy egy meglévőt átnevezel, az már rajtad áll.
Private Sub CommandButton1_Click()
Dim Excel_Filename As String
Dim Point As String
Dim BackSlash As String
Dim BackSlashPos As Integer
'értékadás
Excel_Filename = "c:\a\b\abcdefg.xlsx"
BackSlash = "\"
Point = "."
'található-e benne visszaper jel
BackSlashPos = InStr(1, Excel_Filename, BackSlash, vbTextCompare)
'jobbról balra megkeressük az első pontot(.), hisz addig tart a fájl kiterjesztése
'majd kitöröljük
For i = Len(Excel_Filename) To 1 Step -1
c = Mid(Excel_Filename, i, 1)
If c = Point Then
Exit For
End If
Next
Excel_Filename = Left(Excel_Filename, Len(Excel_Filename) - (Len(Excel_Filename) - i + 1))
'ha korábban nem találtunk benne visszaper jelet, akkor az azt jelenti
'hogy nem tartalmazott útvonalat, csak egy sima fájlnév, ez esetben nem kell
'megkeresni az első visszaperjelet ismét jobbról balra. (azaz magát a fájl nevét)
If BackSlashPos <> 0 Then
For i = Len(Excel_Filename) To 1 Step -1
c = Mid(Excel_Filename, i, 1)
If c = BackSlash Then
Exit For
End If
Next
Excel_Filename = Mid(Excel_Filename, i + 1, (Len(Excel_Filename) - i + 1))
End If
MsgBox (Excel_Filename)
End SubFire.
-
ha esetleg nem érthető amire gondolok...
ha mondjuk a files neve konyv.xls akkor a 4. sorban a Windows("konyv").Activate legyen, de ha lementem a file-t konyvek névre akkor Windows("konyvek").Activate legyen.
Gondolom ezt valami változóval lehet megcsinálni, ahol a változó értéke a files neve kiterjesztés nélkül. Csak azt nem tudom azt hogyan csinálom meg -
ulrik19
tag
Csak azért, hogy mások számára is hasznos legyen a téma
Csináltam egy bővített vlookup() függvényt...
Használata pl:
=multivlookup($E$1:$N$100;3;0;1;A1;4;B1/2;10;"Béla")
ahol:
$E$1:$N$100 a keresés helye (mint vlookup)
3, azaz a tábla 3. oszlopában lévő adatot adja vissza
0, azaz ha nem talál semmit, 0-t adjon vissza. (lehet "" is akkor üresen marad, de bármi más szintén mehet ide)
ez a három kötelező paraméter
ez után lehet megadni a feltételeket az alábbi módon (a fenti példát követve)
párosával kell nézni a paramétereket:
1;A1 azaz a tábla 1. oszlopában A1-gyel egyenlő érték legyen (természetesen nem csak hivatkozás lehet itt)
4;B1/2 azaz a tábla 4. oszlopában a B1 cella értékének felét keresse
10;"Béla" azaz a tábla 10. oszlopában a "Béla" szöveg legyen
lehet 1, de akár több feltételt is belerakni, rugalmasan kezeli
Ha több sor is megfelelne a feltételnek, akkor az első találatot adja vissza
(a paraméterek között ÉS kapcsolat van, tehát mindnek meg kell felelni)Public Function multivlookup(HolKeressen As Range, MelyikOszlopAdatatAdjaVissza As Byte, HaNincsTalalat As Variant, ParamArray OszlopInformaciok() As Variant) As Variant
'Ha nem páros számú az OszlopInformaciok argumentum (az UBound elemszám-1 értéket ad vissza ilyenkor)
If (UBound(OszlopInformaciok) + 1) Mod 2 = 1 Then
'adjon vissza hibát
multivlookup = CVErr(1)
Exit Function
End If
Dim i As Integer, j As Integer, ok As Boolean
For i = 1 To HolKeressen.Rows.Count
ok = True
For j = 0 To UBound(OszlopInformaciok) Step 2
'ha nagyobb oszlopszám a hivatkozás, mint ahány oszlop egyáltalán van...
If HolKeressen.Columns.Count < OszlopInformaciok(j) Then
'adjon vissza hibát
multivlookup = CVErr(2)
Exit Function
End If
'ha nem felel meg a feltételnek, akkor ok = False (ne is vizsgálja ezt az adatsort tovább...)
If HolKeressen.Cells(i, OszlopInformaciok(j)) <> OszlopInformaciok(j + 1) Then
ok = False
Exit For
End If
Next j
'ha van találat, akkor ok = True (ne is menjen tovább, mert az első találot adatom vissza)
If ok Then
multivlookup = HolKeressen.Cells(i, MelyikOszlopAdatatAdjaVissza)
Exit Function
End If
Next i
'ha volt találat, akkor már kiléptünk a függvényből... ha nincs, akkor:
multivlookup = HaNincsTalalat
End Function -
ulrik19
tag
a minta kimenet H4-es cellájában a 4 mit jelent? Mármint hogyan jött ki a táblából?
Ha pl. ugyanabban az idősávban több azonos pass van (station is azonos), akkor mi kerül a célcellába? Az összes megfelelő darabszáma, vagy egy itt nem látható oszlop (talán az említett G) értékösszege? Ha tudsz küldeni egy minta file-t, szerintem nem túl bonyolult megcsinálni.
Egy olyan spec függvényt kell írni rá, ami egyszerre több cella értékét is vizsgálja többféle bevitt paraméter szerint.
-
-
Delila_1
veterán
If Cells(sor, 4) = filteregy And _ 'első feltétel
Cells(sor, 17) = "Visual Inspection - OOW" Then 'második feltétel
If adat = " 1-10" Then q = q + 1 'harmadik feltétel
If adat = "11-20" Then w = w + 1 'harmadik feltételMegőrjít ez a "Programkód", teljesen elrontották a régit.
Nézd meg a filterketto értékadását is, rossz helyen van az idézőjel, és a fil helyett fill szerepel a makródban.
2 for-next ciklusod van, az egyiknek nem adtad meg a next-et, azt hiányolja. Az End Sub elé írd.
-
Delila_1
veterán
-
Delila_1
veterán
AA1 és AA19 közé berakod a 19 különböző filter értéket. Az első 5 eredményt a C25-től lefelé írja ki (ahogy eddig), a következőket D25-től, és így tovább 19 oszlopba.
Adatok nélkül hasraütősen írom a makrót, majd jajgatsz, ha nem jó.Sub visual_filter()
Sheets("IDE_MASOLD").Select
Dim sor, q, w, x, y, z, adat, fil
q = 0: w = 0: x = 0: y = 0: z = 0
For fil = 1 To 19
filteregy = Range("Data!AA" & fil).Text
For sor = 1 To ActiveSheet.UsedRange.Rows.Count
adat = Cells(sor, 13)
If Cells(sor, 4) = filteregy And _
Cells(sor, 17) = "Visual Inspection - OOW" Then
If adat = " 1-10" Then q = q + 1
If adat = "11-20" Then w = w + 1
If adat = "21-30" Then x = x + 1
If adat = "31-60" Then y = y + 1
If adat = "61- " Then z = z + 1
End If
Next
Sheets("Data").Cells(25, 1 + fil) = q
Sheets("Data").Cells(26, 1 + fil) = w
Sheets("Data").Cells(27, 1 + fil) = x
Sheets("Data").Cells(28, 1 + fil) = y
Sheets("Data").Cells(29, 1 + fil) = z
Next
End Sub -
Delila_1
veterán
Ötször hajtod végig az összes adaton a makrót, pedig egyszer is elég lenne. A feltételek vizsgálata is időigényes művelet. Amit lehet, be kell zsúfolni egy ciklusba.
A 3 feltétel közül kettő azonos, ezeket elég 1-szer vizsgálni soronként.
Kétféle módon írtam át, az egyikben If-ek figyelik az adatokat, a másikban a többszörös elágazásra szolgáló Select Case.Sub visual_11()
Sheets("IDE_MASOLD").Select
filteregy = Range("Data!C23").Text
Dim sor, q, w, x, y, z, adat
q = 0: w = 0: x = 0: y = 0: z = 0
For sor = 1 To ActiveSheet.UsedRange.Rows.Count
adat = Cells(sor, 13)
If Cells(sor, 4) = filteregy And Cells(sor, 17) = "Visual Inspection - OOW" Then
If adat = " 1-10" Then q = q + 1
If adat = "11-20" Then w = w + 1
If adat = "21-30" Then x = x + 1
If adat = "31-60" Then y = y + 1
If adat = "61- " Then z = z + 1
End If
Next
Sheets("Data").Cells(25, 2) = q
Sheets("Data").Cells(26, 2) = w
Sheets("Data").Cells(27, 2) = x
Sheets("Data").Cells(28, 2) = y
Sheets("Data").Cells(29, 2) = z
End Sub
Sub visual_Case()
Sheets("IDE_MASOLD").Select
filteregy = Range("Data!C23").Text
Dim sor, q, w, x, y, z, adat
q = 0: w = 0: x = 0: y = 0: z = 0
For sor = 1 To ActiveSheet.UsedRange.Rows.Count
If Cells(sor, 4) = filteregy And Cells(sor, 17) = "Visual Inspection - OOW" Then
adat = Cells(sor, 13)
Select Case adat
Case " 1-10"
q = q + 1
Case "11-20"
w = w + 1
Case "21-30"
x = x + 1
Case "31-60"
y = y + 1
Case "61- "
z = z + 1
End Select
End If
Next
Sheets("Data").Cells(25, 2) = q
Sheets("Data").Cells(26, 2) = w
Sheets("Data").Cells(27, 2) = x
Sheets("Data").Cells(28, 2) = y
Sheets("Data").Cells(29, 2) = z
End Sub -
illetve a végét módosította, ahogy írtad...
Sheets("Data"). Cells(25, 2) = q
Sheets("Data").Cells(26, 2) = w
Sheets("Data").Cells(27, 2) = x
Sheets("Data").Cells(28, 2) = y
Sheets("Data").Cells(29, 2) = zÍgy gyorsabb...
Esetleg arra ötleted, hogy ne kelljen így külön megírni mindet, hanem ugorjon a következő étékre, és fusson le úgy is? Érted amit kérdezni szeretnék?
-
így gondolotam
Sub visua11()
Sheets("IDE_MASOLD").Select
filteregy = Range("Data!C23").Text
Dim sor, sor1, sor2, sor3, sor4, q, w, x, y, z
q = 0
w = 0
x = 0
y = 0
z = 0
For sor = 1 To ActiveSheet.UsedRange.Rows.Count
If Cells(sor, 4) = filteregy And Cells(sor, 13) = " 1-10" And _
Cells(sor, 17) = "Visual Inspection - OOW" Then q = q + 1
Next
For sor1 = 1 To ActiveSheet.UsedRange.Rows.Count
If Cells(sor1, 4) = filteregy And Cells(sor1, 13) = "11-20" And _
Cells(sor1, 17) = "Visual Inspection - OOW" Then w = w + 1
Next
For sor2 = 1 To ActiveSheet.UsedRange.Rows.Count
If Cells(sor2, 4) = filteregy And Cells(sor2, 13) = "21-30" And _
Cells(sor2, 17) = "Visual Inspection - OOW" Then x = x + 1
Next
For sor3 = 1 To ActiveSheet.UsedRange.Rows.Count
If Cells(sor3, 4) = filteregy And Cells(sor3, 13) = "31-60" And _
Cells(sor3, 17) = "Visual Inspection - OOW" Then y = y + 1
Next
For sor4 = 1 To ActiveSheet.UsedRange.Rows.Count
If Cells(sor4, 4) = filteregy And Cells(sor4, 13) = "61- " And _
Cells(sor4, 17) = "Visual Inspection - OOW" Then z = z + 1
Next
Sheets("Data").Select
Cells(25, 2) = q
Cells(26, 2) = w
Cells(27, 2) = x
Cells(28, 2) = y
Cells(29, 2) = z
End Sub -
Delila_1
veterán
Egy kicsit átalakítottam arra az esetre, ha nincs szükséged a laponkénti összegzésre, és a Data lapon egy összegben akarod látni az A14 cellában az összes lap megfelelő sorainak számát.
Sub Xek_1()
Application.ScreenUpdating = False
Dim sor, darab, lap, sor_data
darab = 0
For lap = 2 To Worksheets.Count
Sheets(lap).Select
For sor = 1 To ActiveSheet.UsedRange.Rows.Count
If Cells(sor, 4) = "y" And Cells(sor, 13) = "o" _
And Cells(sor, 17) = "x" Then darab = darab + 1
Next
Next lap
Sheets("Data").Cells(14, 1) = darab
Application.ScreenUpdating = True
End SubAz Application.ScreenUpdating = False sor leállítja a képernyő frissítését, az Application.ScreenUpdating = True pedig visszaállítja azt. Ezt azért tettem be, hogy ne zavarjon, hogy a program egyik lapról a másikra "ugrál".
-
Delila_1
veterán
Nem egészen tiszta, mit akarsz 114-szer átrakni.
Átírtam úgy a makrót, hogy a Data lapon gyűjti össze az adatokat az A2-től kezdve. Az A oszlopba beírja a munkalap nevét, mellé a B-be a darabszámot.
A Data lap legyen a füzetben az első helyen.Nagy különbség! A lapokon a Q oszlopban szereplő x szöveg, míg a makróban lévő szám. Hogy ne zavarjon az azonos kinézet, az x változó nevét átírtam darab-ra, de csak azért, hogy ne zavarjon.
Sub Xek()
Dim sor, darab, lap, sor_data
darab = 0
sor_data = 2
For lap = 2 To Worksheets.Count
Sheets(lap).Select
For sor = 1 To ActiveSheet.UsedRange.Rows.Count
If Cells(sor, 4) = "y" And Cells(sor, 13) = "o" _
And Cells(sor, 17) = "x" Then darab = darab + 1
Next
Sheets("Data").Cells(sor_data, 1) = Sheets(lap).Name
Sheets("Data").Cells(sor_data, 2) = darab
darab = 0
sor_data = sor_data + 1
Next lap
End Sub -
Delila_1
veterán
Makróval:
Sub Xek()
Dim sor, x
x = 0
For sor = 1 To ActiveSheet.UsedRange.Rows.Count
If Cells(sor, 4) = "y" And Cells(sor, 13) = "o" And _
Cells(sor, 17) = "x" Then x = x + 1
Next
MsgBox "Az x-ek száma a megadott feltételek esetén: " & x
End SubHova lett a szerkesztésből a kód? Van helyette a Programkód, de nem olyan jó.
-
Új hozzászólás Aktív témák
Fferi50- iPhone topik
- Huawei Watch GT 6 és GT 6 Pro duplateszt
- Videószerkesztés
- droidic: Windows 11 önállóság nélküli világ: a kontroll új korszaka
- Elektromos autók - motorok
- World of Tanks - MMO
- MILC felhasználók szakmai topikja
- Apple MacBook
- Nyíregyháza és környéke adok-veszek-beszélgetek
- SONY LCD és LED TV-k
- További aktív témák...
- Apple iPhone 17 Pro Deep Blue 120 Hz ProMotion, 8 optikai-minőségű zoom 100% akku ,3 év gari
- GYÖNYÖRŰ iPhone SE 2022 64GB White -1 ÉV GARANCIA - Kártyafüggetlen, MS3366
- HIBÁTLAN iPhone 13 128GB Midnight -1 ÉV GARANCIA - Kártyafüggetlen, MS3687, 100% Akkumulátor
- Gamer PC-Számítógép! Csere-Beszámítás! R5 5500 / RX 6700XT 12GB / 32GB DDR4 / 512GB SSD
- Samsung Galaxy A50 128GB, Kártyafüggetlen, 1 Év Garanciával
Állásajánlatok
Cég: NetGo.hu Kft.
Város: Gödöllő
Cég: Promenade Publishing House Kft.
Város: Budapest