- Android alkalmazások - szoftver kibeszélő topik
- CMF Buds Pro 2 - feltekerheted a hangerőt
- iPhone topik
- Samsung Galaxy Watch7 - kötelező kör
- Megjelent a Poco F7, eurós ára is van már
- Telekom mobilszolgáltatások
- One mobilszolgáltatások
- Vivo X200 Pro - a kétszázát!
- Mobil flották
- Okosóra és okoskiegészítő topik
-
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
-
Delila_1
veterán
Abszolút próba nélkül!
Vegyél fel egy üres lapot, aminek add a Gyűjtőlap nevet. Legyen ez az utolsó lap, hogy ne zavarja meg a makrót a lapok sorrendjében.
A makrót modulba másold (a Téma összefoglaló szerint), és indulhat.Sub Kigyujtes()
Dim lap As Integer, sor As Integer
Sheets("Gyűjtőlap").Select
sor = 2
For lap = 65 To 122
Cells(sor, 1) = Sheets(lap).Range("B5")
Cells(sor, 2) = Sheets(lap).Range("B8")
Cells(sor, 3) = Sheets(lap).Range("B12")
sor = sor + 1
Next
End Sub -
Delila_1
veterán
Kijelölöd a formázni szánt tartományt.
Kezdőlap | Stílusok | Feltételes formázás | Új szabály.
A formázási szabályok közül "A formázandó cellák kijelölése képlettel"-t választod. Az "Értékek formázása, ha ez a képlet igaz" mezőbe beírod a képletet. Az A1 helyére a kijelölésed felső cellájának a címét írd be. Pl. ha a tartományodD2:D200, akkor D2 kerül az A1 helyére. -
Delila_1
veterán
Feltöltöttem.
A Munka1 lap H oszlopába írtam egy képletet. A 3 sorosokkal lesz gond.Készíts másolatot erről a lapról, majd az A oszlopot szűrd az üresekre, töröld ezeket a sorokat. Ezután már a Munka2 lapra könnyen behivatkozhatod a Munka1 lap H oszlopát.
-
Delila_1
veterán
Remekül lehet formázni Excel lapot Weisz Tamás makrójával. Egy régi folyóiratban írta.
A két gomb makrója:
Private Sub cmdHeight_Click()
nHeight = Val(TextHeight.Value)
If nHeight <= 0 Then
MsgBox "A magasságnak nagyobbnak kell lennie nullánál!", vbExclamation, "Cellaméretek"
Exit Sub
End If
If nHeight > 144.2 Then
MsgBox "A legnagyobb sormagasság: 144,2 mm!", vbExclamation, "Cellaméretek"
Exit Sub
End If
For nArea = 1 To Selection.Areas.Count
For nRow = 0 To Selection.Areas(nArea).Rows.Count - 1
Rows(Selection.Areas(nArea).Row + nRow).RowHeight = _
Application.CentimetersToPoints(nHeight / 10)
Next nRow
Next nArea
End SubPrivate Sub cmdWidth_Click()
nWidth = Val(TextWidth.Value)
If nWidth <= 0 Then
MsgBox "A szélességnek nagyobbnak kell lennie nullánál!", vbExclamation, "Cellaméretek"
Exit Sub
End If
nPoints = Application.CentimetersToPoints(nWidth / 10)
If nWidth > 473.6 Then
MsgBox "A maximális szélesség: 473,6 mm", vbExclamation, "Cellaméretek"
Exit Sub
End If
Application.ScreenUpdating = False
For nArea = 1 To Selection.Areas.Count
For nCol = 0 To Selection.Areas(nArea).Columns.Count - 1
nColNo = Selection.Areas(nArea).Column + nCol
While Columns(nColNo + 1).Left - Columns(nColNo).Left - 0.1 > nPoints
Columns(nColNo).ColumnWidth = Columns(nColNo).ColumnWidth - 0.1
Wend
While Columns(nColNo + 1).Left - Columns(nColNo).Left + 0.1 < nPoints
Columns(nColNo).ColumnWidth = Columns(nColNo).ColumnWidth + 0.1
Wend
Next nCol
Next nArea
Application.ScreenUpdating = True
End Sub -
Delila_1
veterán
Úgy tűnik, az ÖSSZ.MUNKANAP függvény nem minden esetben felel meg. Régebbi függvényekkel megoldható a feladat.
H3:
=DARABTELI(INDIREKT("B" & HOL.VAN($F$3;$A:$A;0) &":B"&HOL.VAN($G$3;$A:$A;0));H$2)
I3:=DARABTELI(INDIREKT("B" & HOL.VAN($F$3;$A:$A;0) &":B"&HOL.VAN($G$3;$A:$A;0));I$2)
J3:=H3+I3 -
Delila_1
veterán
Sub Elrejt()
Dim usor As Long, sor As Long
usor = Range("C" & Rows.Count).End(xlUp).Row
For sor = usor To 1 Step -1
If Cells(sor, "C") = "" Then Rows(sor).EntireRow.Hidden = True
Next
End SubSub Felfed()
Dim usor As Long, sor As Long
usor = Range("C" & Rows.Count).End(xlUp).Row + 1
For sor = 1 To usor
If Cells(sor, "C") = "" Then Rows(sor).EntireRow.Hidden = False
Next
End Sub -
Delila_1
veterán
válasz
gepesz13
#43433
üzenetére
Vidd be a kép szerint a dátumokat egy lapra.
Az A2: A13 tartománynak adj nevet, legyen Ünnep, a C2: C3 neve legyen Szabadnap.
A másik lapon vannak a dátumaid az A2: A367 tartományban. Erre adj feltétételes formázást, ahol a képlet=ÉS(DARABTELI(Szabadnap;A2)=0;VAGY(HÉT.NAPJA(A2;2)>5;DARABTELI(Ünnep;A2)>0))
Adj kitöltő színt. -
Delila_1
veterán
válasz
bucihost
#43407
üzenetére
Találomra egy linkről letöltöttem, ezt a makrót kaptam:
Sub Rögzítés1()
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://menetrend.derke.hu/?getlines=23,1", Destination:=Range("A1"))
.Name = "?getlines=23,1"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
End Sub -
#43345
Delila_1
veterán
Lasersailing
#43344
Delila_1
veterán
válasz
Lasersailing
#43344
üzenetére
Erre. Most állítottad be, vagy így volt?
-
#43343
Delila_1
veterán
Lasersailing
#43342
Delila_1
veterán
válasz
Lasersailing
#43342
üzenetére
A beállításoknál ki van kapcsolva az automatikus számolás.
-
-
Delila_1
veterán
válasz
ROBOTER
#43309
üzenetére
Az érvényesítésben szereplő adatokhoz adj címsort, majd a Beszúrás | Táblázat menüben alakítsd táblázattá. A kép szerint adj nevet az adatokat tartalmazó soroknak.
Rendeld a lenti makrót a lapodhoz, ahol az A oszlopba be akarod vinni az érvényesítést.
Ügyelj rá, hogy az az oszlop, ahova írni akarsz, ne legyen zárolt.
Szerek.: Mivel táblázattá alakítottad az érvényesítéshez szükséges adatokat, a táblázat bővülésekor automatikusan bővül a Lista nevű tartomány, nem kell külön gondoskodni róla.Private Sub Worksheet_Change(ByVal Target As Range)
ActiveSheet.Unprotect
With Cells(Target.Row, 1).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=Lista"
End With
Cells(Target.Row, 1).Activate
ActiveSheet.Protect
End Sub -
Delila_1
veterán
válasz
Fferi50
#43303
üzenetére
Nem szűnik meg a füzet bezárása után sem a lap védettsége.
Ha eredetileg nem volt védve a lap, aSheets(x).Protect Password:="Jelszó" , UserInterfaceOnly:=True
sor akkor is védetté teszi.
Védelemnél azt is be szoktam állítani, hogy a zárolt cellákat ne lehessen kijelölni.Sheets(x).EnableSelection = xlNoSelection -
Delila_1
veterán
válasz
ROBOTER
#43273
üzenetére
Nem mutattad meg, de talán az általam leírt módszer is jó.
Két AxtiveX vezérlőt tettem a Munka2 lapra. Ezeknek az az előnyük az érvényesítéssel szemben, hogy a kezdőbetűt leütve a listában szereplő kezdetű tételre ugrik a kijelölés. A ComboBox1-ben a kategóriát választhatod ki, a ComboBox2-ben a terméket. A Munka1 lapon vannak a táblázatok, amikben a második sortól az utolsóig elneveztem a tartományokat a címsornak megfelelően.
A makró a 2 vezérlőhöz:
Private Sub ComboBox1_Change()
ComboBox2.ListFillRange = "Munka1!" & ComboBox1
End Sub
Private Sub ComboBox2_Change()
Dim sor As Long, oszlop As Integer
sor = Selection.Row
Select Case ComboBox1.Value
Case "keresztnév": oszlop = 1
Case "város": oszlop = 2
Case "zöldség": oszlop = 3
Case "gyümölcs": oszlop = 4
End Select
Cells(sor, oszlop) = ComboBox2.Value
End SubÁllsz a soron a Munka2 lapon, ahova be akarod vinni az adatot, és kiválasztod a kategóriát, majd a terméket. Beírja, ahova kell.
-
#43271
Delila_1
veterán
Los Angeles
#43269
Delila_1
veterán
válasz
Los Angeles
#43269
üzenetére
Szűröd színre, és a RÉSZÖSSZEG függvénnyel összegzed a látható tartományt.
-
Delila_1
veterán
válasz
ny.erno
#43238
üzenetére
Külön oszlopokba írd a termékeket. A megfelelő cellákba elég egy betűt írnod. Ha nem volt még a termékednek lapja, a makró létrehozza. Beírja az adatokat a megfelelő helyekre.
A makrót az Adatbazis laphoz kell rendelned.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lapnev, usor As Long, LN As String, uoszlop As Integer
uoszlop = Cells(1, Columns.Count).End(xlToLeft).Column
If Target.Column > 2 And Target.Column < uoszlop And Target.Row > 1 And Target.Count = 1 Then
Application.EnableEvents = False
On Error Resume Next
LN = Cells(1, Target.Column)
Set lapnev = Sheets(LN)
If Err.Number <> 0 Then
Sheets.Add.Name = LN
Sheets(LN).Move After:=Sheets.Count + 1
On Error GoTo 0
End If
With Sheets(LN)
.Cells(1) = "Név": .Cells(2) = "Email"
.Cells(3) = "Termék": .Cells(4) = "Kapcsolati forrás"
usor = .Range("A" & Rows.Count).End(xlUp).Row + 1
.Cells(usor, 1) = Cells(Target.Row, "A")
.Cells(usor, 2) = Cells(Target.Row, "B")
.Cells(usor, 3) = LN
.Cells(usor, 4) = Cells(Target.Row, uoszlop)
End With
Sheets("Adatbazis").Move Before:=Sheets(1)
Application.EnableEvents = True
End If
End SubSzerk.: a termékek számát bővítheted, vagy szűkítheted.
-
Delila_1
veterán
Itt van magyarázatokkal a makró.
Sub Elrendezes()
Dim sor As Long, usor As Long
Dim WS1 As Worksheet, WS2 As Worksheet
Application.ScreenUpdating = False 'képernyő frissítés leállítása, gyorsabb végrehajtás
Set WS1 = Sheets("Munka1") 'innen kezdve a Sheets("Munka1") helyett elég WS1-et írni
Set WS2 = Sheets("Munka2") 'innen kezdve a Sheets("Munka2") helyett elég WS2-et írni
usor = WS1.Range("A" & Rows.Count).End(xlUp).Row 'alsó sor a Munka1 lapon
For sor = 1 To usor
'az InStr a szöveg.keres VBA-s változata
'ha van a szövegben ":", de nem "Cikkszám:", akkor bontsa ketté a szöveget az A és B oszlopokba
'a mintád 57. sorában
' "BAKONYTHERM 30 N+F belső teherhordó fal, 300x250x240 mm, I.o., Cikkszám:TÉG13 M 2,5 (Hf30-cm) falazó, meszes cementhabarcs"
'szerepel, emiatt kellett a 2. feltételt berakni
If InStr(WS1.Cells(sor, 1), ":") > 0 And InStr(WS1.Cells(sor, 1), "Cikkszám") = 0 Then
WS2.Cells(sor, 1) = Left(WS1.Cells(sor, 1), InStr(WS1.Cells(sor, 1), ":"))
WS2.Cells(sor, 2) = Mid(WS1.Cells(sor, 1), InStr(WS1.Cells(sor, 1), ":") + 1, 70)
Else
WS2.Cells(sor, 1) = WS1.Cells(sor, 1) 'ha nincs ":", akkor a teljes szöveg az A-ba
End If
'formátum másolás Munka1-ről Munka2-re az A és B oszlopban a félkövér sorok miatt
WS1.Cells(sor, 1).Copy
WS2.Range("A" & sor & ":B" & sor).PasteSpecial xlPasteFormats
Next
'csere funkció, a " Ft/m2" és " Ft/óra" cseréje semmire
WS2.Cells.Replace What:=" Ft/m2", Replacement:=""
WS2.Cells.Replace What:=" Ft/óra", Replacement:=""
WS2.Columns("A:A").ColumnWidth = 13.71 'az A oszlop kiszélesítése
Application.ScreenUpdating = True 'képernyő frissítés engedélyezése
End Sub -
Delila_1
veterán
Vegyél fel az 1.xlsx-ben egy új lapot, Munka2 néven.
Modulba tedd a makrót, és indíthatod.
A füzetet makróbarátként kell elmentened, ha máskor is akarod futtatni.Sub Elrendezes()
Dim sor As Long, usor As Long
Dim WS1 As Worksheet, WS2 As Worksheet
Application.ScreenUpdating = False
Set WS1 = Sheets("Munka1")
Set WS2 = Sheets("Munka2")
usor = WS1.Range("A" & Rows.Count).End(xlUp).Row
For sor = 1 To usor
If InStr(WS1.Cells(sor, 1), ":") > 0 And InStr(WS1.Cells(sor, 1), "Cikkszám") = 0 Then
WS2.Cells(sor, 1) = Left(WS1.Cells(sor, 1), InStr(WS1.Cells(sor, 1), ":"))
WS2.Cells(sor, 2) = Mid(WS1.Cells(sor, 1), InStr(WS1.Cells(sor, 1), ":") + 1, 70)
Else
WS2.Cells(sor, 1) = WS1.Cells(sor, 1)
End If
WS1.Cells(sor, 1).Copy
WS2.Range("A" & sor & ":B" & sor).PasteSpecial xlPasteFormats
Next
WS2.Cells.Replace What:=" Ft/m2", Replacement:=""
WS2.Cells.Replace What:=" Ft/óra", Replacement:=""
WS2.Columns("A:A").ColumnWidth = 13.71
Application.ScreenUpdating = True
End Sub -
Delila_1
veterán
válasz
ROBOTER
#43203
üzenetére
Csak makróval tudom megoldani. A makrót a lapodhoz kell rendelned.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 And Target.Value = "igen" Then '*
With Cells(Target.Row, "B").Validation '**
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:="=$J$1:$J$7" '***
End With
End If
End Sub3 sorhoz tettem *-ot.
* nálam az igen-nem választás az A oszlopban van, ezért Column=1. Nálad a te oszlopod sorszámát add meg helyette.
** a B oszlopba viszem be a választási lehetőséget az érvényesítéshez, a B helyett ad meg a saját oszlopod betűjelét.
*** a $J$1:$J$7 helyébe a saját listád címét add meg. -
Delila_1
veterán
Javaslom, hogy a /B-nek és hasonlóknak (emelet, ajtó) szúrj be az F oszlop elé egy új oszlopot, hogy az E oszlopban csak számok legyenek. A mostani, szövegként tárolt számokat könnyedén valódi számokká alakíthatod. Valahol egy üres cellába beírsz egy 1-est, másolod, majd a házszámokat tartalmazó területre irányítottan beilleszted értékként, a művelet legyen szorzás. Az 1-est törölheted.
Most, hogy már igazi házszámaid vannak, rendezheted a tartományt az A, majd D, végül az E oszlop szerint. -
#43161
Delila_1
veterán
Roland861010
#43160
Delila_1
veterán
válasz
Roland861010
#43160
üzenetére
Szivi
-
#43159
Delila_1
veterán
Roland861010
#43158
Delila_1
veterán
válasz
Roland861010
#43158
üzenetére
A J oszlopra tegyél feltételes formázást, a képlet
=BAL(J1;10)*1<=MA()-1 -
#43156
Delila_1
veterán
Roland861010
#43155
Delila_1
veterán
válasz
Roland861010
#43155
üzenetére
A feladat celláját is színezni akarod?
-
#43154
Delila_1
veterán
Roland861010
#43153
Delila_1
veterán
válasz
Roland861010
#43153
üzenetére
Formázhatod a dátumokat tartalmazó oszlopot. A képlet nálam az A oszlopra vonatkozik.
-
Delila_1
veterán
válasz
kat0na
#43145
üzenetére
Ahhoz a laphoz kell rendelned a makrót, amelyikre az 1-eseket akarod beíratni.
Ahányszor rálépsz a kérdéses lapra, "letapogatja" a Munka1 lap celláit, és beírja a feltétel szerint az 1-et, ahova kell. A feltételnél a Munka1 helyére írd be a lapot igazi nevét.Private Sub Worksheet_Activate()
Dim CV As Range
For Each CV In Range("H9:AF100")
If Sheets("Munka1").Range(CV.Address).Font.ColorIndex = 3 Then Range(CV.Address) = 1
Next
End Sub -
Delila_1
veterán
válasz
zsolti_20
#43114
üzenetére
Az AA oszlopba sorold fel a fájlneveket, kiterjesztéssel.
A makró sorra megnyitja a fájlokat. Első esetben a B oszlopba írja be a képleteket, amik az első fájlból keresik ki az értékeket.
Ahhoz, hogy a következő fájlnál ne írja ezeket felül, a másodikban való kereséshez a képletek a C oszlopba kerülnek, és így tovább. Nézd meg a Case utasításoknál, hogy mi változik.
Az első sorában az oszlop helye (B: B), a másodikban a félkövér, aláhúzott karakterrel írt érték.
"=IFERROR(VLOOKUP(RC[-1],[" & FN & "]Munka1!C1: C2,2,0),"""")"
A Case 5-től majd beírod a többit.Sub Kigyujtes()
Dim WsGy As Worksheet, WsInnen As Worksheet, usorGy As Long, szamlalo As Integer
Dim FN As String, sor As Long, usorFajlnev As Long, utvonal As String
utvonal = "F:\Főmappa\Almappa\" 'ide jön a saját útvonalad, a végén \ legyen
Set WsGy = ActiveWorkbook.Sheets(1)
usorGy = WsGy.Range("A" & Rows.Count).End(xlUp).Row
usorFajlnev = WsGy.Range("AA" & Rows.Count).End(xlUp).Row
szamlalo = 1
For sor = 1 To usorFajlnev
FN = Cells(sor, "AA") 'itt vannak a fájlnevek kiterjesztéssel
Workbooks.Open utvonal & FN
szamlalo = szamlalo + 1
Set WsInnen = ActiveWorkbook.Sheets(1)
Select Case szamlalo
Case 2
WsGy.Range("B1:B" & usorGy).FormulaR1C1 = _
"=IFERROR(VLOOKUP(RC[-1],[" & FN & "]Munka1!C1:C2,2,0),"""")"
Case 3
WsGy.Range("C1:C" & usorGy).FormulaR1C1 = _
"=IFERROR(VLOOKUP(RC[-2],[" & FN & "]Munka1!C1:C2,2,0),"""")"
Case 4
WsGy.Range("D1:D" & usorGy).FormulaR1C1 = _
"=IFERROR(VLOOKUP(RC[-3],[" & FN & "]Munka1!C1:C2,2,0),"""")"
Case 5
Case 6
Case 7
Case 8
Case 9
Case 10
Case 11
End Select
ActiveWorkbook.Close False
'ha a képletek helyett fix értékeket szeretnél, a lenti két sort aktiváld
' Range("B:K").Copy
' Range("B1").PasteSpecial xlPasteValues
Next
End Sub -
Delila_1
veterán
válasz
zsolti_20
#43112
üzenetére
Inkább tegyél fel egy képet, amin látszik hogy milyen oszlopok vannak az gyűjtő-, és a többi füzetben. A többiből melyik adatokat kell bemásolni a gyűjtőbe.
A valós elrendezést küldd, ne úgy, hogy a gyűjtőben "például" a B oszlop adataihoz kell párosítani a többi füzet D oszlopának az adatait. Az adatok lehetnek kitaláltak, de az elrendezés NEM. -
Delila_1
veterán
válasz
zsolti_20
#43110
üzenetére
Set FD = Application.FileDialog(3)
With FD
.AllowMultiSelect = False 'letiltja a többszörös kijelölést
.Show 'Indítja a dialógboxot
If .SelectedItems.Count = 0 Then
MsgBox "Nem választottál fájlt, befejezzük.", vbInformation
Else
Fajnev= .SelectedItems(1)
'Fajnev megnyitása
w1.Activate 'ha kell, az első füzet aktívvá tétele
'műveletek
'megnyitott füzet bezárása
End If
End WithMásik módszer lehet, hogy a wb1-ben felsorolod egy oszlopban a fájlokat, és egy ciklusban nyitod meg és hajtod végre az utasításokat, zárod be a megnyitott füzetet. A megnyitandó fájl nevét a felsorolásból veszed.
sor=1
Do While Cells(sor,1)<>""
FN=Cells(sor,1)
Workbooks.Open utvonal & FN
'...
'...
sor=sor+1
Loop -
Delila_1
veterán
-
Delila_1
veterán
válasz
zsolti_20
#43102
üzenetére
Ügyelj rá, hogy az utvonal értékadása "\"-re végződjön.
Sub Lapnevek()
Dim FN As String, lap As Integer, WS As Worksheet, WB As Workbook
Dim utvonal As String
utvonal = "D:\Főmappa\Almappa\" 'megnyitandó fájl útvonala
FN = "Fájlnév.xlsx" 'megnyitandó fájl neve
Set WS = ActiveWorkbook.Sheets(1)
Workbooks.Open utvonal & FN
Set WB = ActiveWorkbook
WS.Activate
With Workbooks(WB.Name)
For lap = 1 To .Sheets.Count
Cells(lap, "A") = WB.Sheets(lap).Name
Next
End With
WB.Close False
End Sub -
Delila_1
veterán
válasz
zsolti_20
#43094
üzenetére
Makró nélküli megoldás a képek megjelenítéséhez.
Két lapod van. A képeket tartalmazó neve Terméklista, a másiké Megjelenítés.
A Terméklistára viszed fel a képeket a csatolt kép szerint. Az A oszlopba írod a megnevezést. Közvetlenül alatta bekeretezel egy (a példa szerint 10×4-es, de lehet más) területet, ide szúrod be a képet középre.
A kép nevét beírod a G oszlopba, jöhet a következő kép. Mikor mindet felvitted, mehetünk a másik lapra.
A B1 cellában érvényesítést adsz meg, ami a Terméklista G oszlopára mutat. Kiválasztasz egy képet.
A Képletek | Névkezelőben létrehozol egy újat. A neve legyen Kep_mutatasa, a képlet=ELTOLÁS(Terméklista!$A$1;HOL.VAN(Megjelenítés!$B$1;Terméklista!$A:$A;0);0;10;4)
ahol a 10 a másik lapon egy-egy kép magassága, a 4 pedig a szélessége.
Beszúrsz egy akármilyen képet az érvényesítés alá. Ráállsz a képre, és a szerkesztőlécen megadod a hivatkozást:=Kep_mutatasa
Ezzel kész. Mindig az a kép jelenik meg a Megjelenítés lapon, amit a B1 cella érvényesítésében kiválasztasz. -
Delila_1
veterán
válasz
petymeg
#43090
üzenetére
Tegyük fel, hogy a számok A1-től kezdve lefelé vannak. A képlet =A1*10, ezt másolhatod lefelé.
Ha nem a képletek kellenek, hanem a felszorzott összegek, van egy egyszerű megoldás. Egy üres cellába beírsz egy 10-est. Ezt másolod Ctrl+c-vel, majd kijelölöd a felszorzandó számok tartományát. Irányított beillesztés menüpont, a Művelet résznél bejelölöd a szorzást. A beírt 10-est törölheted. -
Delila_1
veterán
válasz
zsolti_20
#43077
üzenetére
A számokat sorold fel valahol egymás alatt, és hozz létre az A1 cellában egy érvényesítést ezekből. Feltételezem, hogy a számok egy-egy kép nevével megegyeznek.
Rajzolj egy négyzetet (beszúrás, ábrák, alakzatok), aminek a Kép nevet adod.
Private Sub Worksheet_Change(ByVal Target As Range)
Const utvonal As String = "F:\Jpg\"
If Target.Address = "$A$1" Then
ActiveSheet.Shapes.Range("Kép").Select
Selection.ShapeRange.Fill.UserPicture utvonal & Target.Value & ".jpg"
Cells(1).Select
End If
End SubRendeld a makrót a lapodhoz. Írd át az utvonal változót a saját útvonaladra, a végén legyen "\".
Ha nem jpg kiterjesztésűek a képeid, aSelection.ShapeRange.Fill.UserPicture utvonal & Target.Value & ".jpg"
sor végén írd át. -
Delila_1
veterán
válasz
Roxy27
#42998
üzenetére
Idézek a Téma összefoglalóból:
"Ne azt írd, hogy például az A oszlop szűrt adatait szeretnéd a C oszlopba másolni, ha valójában a B oszlop szűrt adatai kellenek egy másik lap X oszlopába."Ahhoz, hogy el tudjam küldeni a fájlt, újra be kellene vinnem mindent egy új füzetbe, mert természetesen nem mentettem el a feladatodat. Az eredmény az lenne, amit a képen látsz, a képből is kikövetkeztetheted a valódi megoldást. Nem véletlenül kértem az elrendezésedet, mert ahhoz kellett volna igazítanom a képleteket.
Mások is elkövetik ezt a hibát, hogy nem az eredeti felállást küldve kérnek segítséget, majd közlik, hogy másról van szó. Igazán érdekel, miért küldtél más formátumot, mint a valódi. Kérlek, írd meg!
Ha nem sikerül összehoznod, küldd el Te a fájlodat, akkor biztos leszek benne, hogy nem dolgozom duplán a képletekkel, és nem kell nekem bevinni az adatokat.
-
#42991
Delila_1
veterán
Fire/SOUL/CD
#42989
Delila_1
veterán
válasz
Fire/SOUL/CD
#42989
üzenetére
Függvény sem kell.
=vég_dátumot tartalmazó cella címe - kezdő_dátumot tartalmazó cella címe. -
-
Delila_1
veterán
válasz
zsolti_20
#42982
üzenetére
Óhajod parancs.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim WF As WorksheetFunction
Application.EnableEvents = False
Set WF = Application.WorksheetFunction
ActiveSheet.Protect Password:="szupertitkosjelszó", UserInterfaceOnly:=True
If WF.CountA(Range("A" & Target.Row & ":E" & Target.Row)) = 5 Then Rows(Target.Row + 1).Locked = False
If WF.CountA(Range("A" & Target.Row & ":E" & Target.Row)) = 0 Then
Range("A" & Target.Row + 1 & ":E" & Target.Row + 1) = ""
Rows(Target.Row + 1).Locked = True
End If
Application.EnableEvents = True
End Sub
Új hozzászólás Aktív témák
Hirdetés
- Telekom otthoni szolgáltatások (TV, internet, telefon)
- Vezetékes FEJhallgatók
- Miskolc és környéke adok-veszek-beszélgetek
- Óvodások homokozója
- A nagy Szóda, Szódakészítés topic - legyen egy kis fröccs is! :-)
- Kecskemét és környéke adok-veszek-beszélgetek
- Intel Core i5 / i7 / i9 "Alder Lake-Raptor Lake/Refresh" (LGA1700)
- AMD Ryzen 9 / 7 / 5 9***(X) "Zen 5" (AM5)
- Revolut
- 3D nyomtatás
- További aktív témák...
- Windows, Office licencek kedvező áron, egyenesen a Microsoft-tól - Automata kézbesítés utalással is!
- Bontatlan - BATTLEFIELD 1 Collectors Edition - Játékszoftver nélkül
- Windows 10 11 Pro Office 19 21 Pro Plus Retail kulcs 1 PC Mac AKCIÓ! Automatikus 0-24
- Számlás!Steam,EA,Epic és egyébb játékok Pc-re vagy XBox!
- Adobe Előfizetések - Adobe Creative Cloud All Apps - 12 Hónap - NYÁRI AKCIÓ!
- AKCIÓ! AMD Ryzen 9 3900X 12 mag 24 szál processzor garanciával hibátlan működéssel
- BESZÁMÍTÁS! 32GB (2x16) G.Skill Trident Z RGB 6600MHz DDR5 memória garanciával hibátlan működéssel
- ÁRGARANCIA!Épített KomPhone Ryzen 5 7600X 32/64GB RAM RTX 5070 12GB GAMER PC termékbeszámítással
- Csere-Beszámítás! Asus Rog Strix RTX 3070Ti 8GB GDDR6X Videokártya!
- Samsung Galaxy A12 64GB, Kártyafüggetlen, 1 Év Garanciával
Állásajánlatok
Cég: CAMERA-PRO Hungary Kft
Város: Budapest
Cég: PC Trade Systems Kft.
Város: Szeged