-
Fototrend
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
válasz
bteebi
#21878
üzenetére
Sub osszeir()
Dim lap%, tartomany As Range, CV As Range
Dim oszlop As Integer, betu As String
For lap% = 1 To Sheets.Count
If Sheets(lap%).Name <> "osszeir" Then
Sheets(lap%).Select
Range("A5").Select
Set tartomany = Selection.CurrentRegion
For Each CV In tartomany
Debug.Print CV.Address
If CV.Interior.ColorIndex = 3 Then
betu = Cells(6, CV.Column)
If CV.Column Mod 2 = 0 Then
oszlop = CV.Column
Else
oszlop = CV.Column - 1
End If
Sheets("osszeir").Range(CV.Address) = "0" & Cells(5, oszlop) & "-" & _
betu & "-" & Cells(CV.Row, 1) & "h"
End If
Next
End If
Next
Sheets("osszeir").Select
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 -
Delila_1
veterán
válasz
pigster
#21841
üzenetére
Formátum a vonal eltüntetéséhez: # ###_,_— (alsó kötjel, vessző, alsó kötjel, 0151)
A képlet marad az előbbi.A formátumnál az alsó kötjel után megadott karakter szélességének megfelelően ad egy jobb oldali behúzást.
Például a 0,0_W a bevitt szám mögött egy W-nek megfelelő szélességű üres helyet hagy.Itt két karakterrel, a vesszővel, és a hosszú kötjellel kell behúzni, mindegyikhez külön be kell írni az alsó kötjelet.
-
-
Delila_1
veterán
válasz
toth60
#21831
üzenetére
A lapvédelem előtt add meg a háttérszínt az összes cellának. A makró a védett tartomány hátterét fehérre állítja a védelemmel azonos időben.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 5 Then
ActiveSheet.Protect Password:="aaa", UserInterfaceOnly:=True
Rows(Target.Row).Locked = True
Range("A" & (Target.Row) & ":E" & Target.Row).Interior.Color = vbWhite
End If
End Sub -
Delila_1
veterán
válasz
toth60
#21828
üzenetére
Én vagyok a hibás. Az 1. pontban nem írtam meg, hogy az írható cellák zárolását vedd le, akkor már nem lesz hiba.
Ha azt akarod, hogy az 5. (E) oszlopba írás után legyen a teljes sor zárolt, akkor az A:E oszlopok celláinak a zárolása elől vedd ki a pipát a cellaformázásnál, a makró pedig a laphoz rendelve:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 5 Then
ActiveSheet.Protect Password:="aaa", UserInterfaceOnly:=True
Rows(Target.Row).Locked = True
End If
End SubA makró bemásolásakor írd át az aaa jelszót a saját jelszavadra.
-
Delila_1
veterán
válasz
toth60
#21826
üzenetére
1. Jelöld ki együttesen a cellákat, amikbe engeded a beírást. Ezt például a Ctrl billentyű nyomva tartása mellett a cellákra kattintással teheted meg.
2. Adj nevet a kijelölt területnek, legyen a név zárolni.
3. Védd le a lapot. A védelemnél a Zárolt cellák kijelölése elől vedd ki a pipát, a Nem zárolt cellák kijelölése legyen kijelölve. Nálam a jelszó aaa, ehelyett vigyél be valami mást.
4. Lapfülön jobb klikk, Kód megjelenítése. Bejutottál a VB szerkesztőbe, ahol a jobb oldali üres felületre másold be a lenti makrót.
5. Írd át az
ActiveSheet.Protect Password:="aaa", UserInterfaceOnly:=True
sorban az aaa-t a saját jelszavadra, indulhat a munka.Private Sub Worksheet_Change(ByVal Target As Range)
ActiveSheet.Protect Password:="aaa", UserInterfaceOnly:=True
If Not Intersect(Target, Range("zárolni")) Is Nothing Then Range(Target.Address).Locked = True
End Sub -
Delila_1
veterán
válasz
David888
#21812
üzenetére
Szia!
A verseny lap D4-es cellájában a képlet
=INDEX(iskola!A:D;HOL.VAN(D4;iskola!D:D;0);1)A súgóból:
Szintaktika: INDEX(tömb;sor_szám;oszlop_szám)
Táblázat vagy tömb azon elemének értékét adja vissza, amelyet a sorszám és oszlopszám mint index meghatároz.A képletben a sor_számot a HOL.VAN függvénnyel határoztam meg, ahol pontos értéket kerestem (az utolsó paraméter 0). Az oszlop_szám értéke 1, mert az iskolák nevét az első oszlop tartalmazza.
Így is lehetett volna:
=INDEX(iskola!$A$1:$D$5;HOL.VAN(D4;iskola!D:D;0);1)
Ha az iskola lapon nem a teljes A
oszlopot adom meg, akkor a tartományt fixen kell megadni, erre szolgálnak a $ jelek. -
Delila_1
veterán
Kevés változtatással:
Sub Laptorles()
Dim lap As Integer
Application.DisplayAlerts = False
For lap = Sheets.Count To 1 Step -1
If Sheets(lap).Name <> "sorsolás" And Sheets(lap).Name <> "összesítő" Then
Sheets(lap).Delete
End If
Next
Application.DisplayAlerts = True
End SubFor-Next ciklusban a törléseket célszerű a tartomány végétől az elejéig végrehajtani. Ez főként sorok, oszlopok törlésére vonatkozik.
-
Delila_1
veterán
Sub Valami()
Dim sor As Integer, sor1, WS2 As Worksheet, WF As WorksheetFunction
Set WS2 = Worksheets("Munka2")
Set WF = Application.WorksheetFunction
Sheets("Munka1").Select
For sor = 10 To 13
sor1 = 0
On Error Resume Next
sor1 = WF.Match(Cells(sor, "N"), WS2.Columns("N"), 0)
WS2.Cells(sor1, "O") = WS2.Cells(sor1, "O") + Cells(sor, "O")
Next
End Sub -
Delila_1
veterán
válasz
bagira82
#21788
üzenetére
Sub diagram()
a = "Anna": b = "Józsi": c = "Emil": d = "Tamás"
aa = 100: bb = 120: cc = 140: dd = 200
tengely = Array(a, b, c, d)
ertekek = Array(aa, bb, cc, dd)
ActiveSheet.Shapes.AddChart.Select
With ActiveChart
.ChartType = xl3DPieExploded
.SeriesCollection.NewSeries
With .SeriesCollection(1)
.Name = "='Munka5'!$B$1"
.Values = ertekek
.XValues = tengely
.ApplyDataLabels
End With
End With
End Sub -
Delila_1
veterán
válasz
bagira82
#21784
üzenetére
Sub diagram()
ertekek = Array(103, 405, 349, 532)
tengely = Array("Anna", "Teri", "Emil", "Ida")
ActiveSheet.Shapes.AddChart.Select
With ActiveChart
.ChartType = xl3DPieExploded
.SeriesCollection.NewSeries
With .SeriesCollection(1)
.Name = "='Munka5'!$B$1"
.Values = ertekek
.XValues = tengely
.ApplyDataLabels
End With
End With
End Sub -
#21772
Delila_1
veterán
marchello1
#21770
Delila_1
veterán
válasz
marchello1
#21770
üzenetére
Szívesen.
-
#21767
Delila_1
veterán
marchello1
#21765
Delila_1
veterán
válasz
marchello1
#21765
üzenetére
Az A4:A33 tartomány feltételes formázásának a képlete
=HÓNAP(A4)>HÓNAP(A$3), ehhez fehér karakterszínt rendelj, és add meg a többi oszlopra is. Fontos a $ jel a hármas előtt!
-
Delila_1
veterán
válasz
Zola007
#21755
üzenetére
Írtam hozzá egy felhasználói függvényt.
Function Osszegszer(osszeg As String, szorzo)
kk = Split(osszeg, ", ")
For i = 0 To UBound(kk)
osszeadando = osszeadando + kk(i) * 1
Next
szorzat = osszeadando * szorzo
Osszegszer = szorzat
End FunctionA makrót bemásolod a füzetedbe egy új modulba (a VB szerkesztőben).
A példád szerint a füzetben így adod meg: =Osszegszer(A10;B10)A zárójelben az első paraméter annak a cellának a címe, amiben a számok vannak vesszővel és szóközzel elválasztva, a második a szorzót tartalmazó cella címe.
-
Delila_1
veterán
válasz
slashing
#21752
üzenetére
Nem értettelek félre, csak javasoltam egy egyszerű megoldást, amit autoszűrővel hajthatsz végre.
Irányított szűrővel is megkaphatnád az eredményt, de ahhoz is minden sorban kellene szerepelnie a sorszámnak. Az Excel módot ad a cellák összevonására, de sok esetben – mint a példádban is – nem tudja helyesen kezelni.Átlátható marad a táblázatod, ha ügyesen adsz feltételes formázást. Az A3 cellától lefelé kell kijelölnöd az A oszlopban kitöltött tartományt, miután megszüntetted a cellák összevonását.
Az egyik képlet a formátumban =A3=A2, itt a karakter színét kell beállítanod a háttér színére, a feltett kép szerint fehérre.
A másik képlet =A3<>A2, ennél egy felső szegélyt kell beállítanod..
A B:C tartomány legyen kívül-belül szegélyezve. Az A oszlop hátterét fehérre állítva a cellarácsok sem zavarják a képet, de a beállításoknál is megszüntetheted a cellarácsok megjelenítését.
Ilyen lesz:
-
Delila_1
veterán
Egy halom idézőjelet tettél bele feleslegesen, és a $-t kihagytad.
Jelöld ki az A2:F4 területet. A formázás képlete: =$E2="nem"
Add meg a formátumot, és kész. Új szabály, ugyanez a képlet, csak a "nem" helyére "igen" jön, és a háttér zöld.A további sorokra a formátumfestő ecsettel másolhatod a formátumot, vagy a feltételes formázás | Szabályok kezelése ablakában egyszerűen átírod az érvényességet a teljes területedre.
-
Delila_1
veterán
válasz
Gabcsika
#21735
üzenetére
Feltöltöttem az átírt makróval a füzetedet ide.
Igaz, ahogy itt írtam, a lapnevek kijavításával helyre rázódott volna a lelke, de most egy-egy oldalnyi adat átmásolása után üzenetet kapsz a nyomtatásra.
Az F1 cella tartja számon a Munka1 lapon, hogy hol tartasz a másolással és nyomtatással, azt ne töröld ki. Mikor mindent kinyomtattál, akkor vált át üres stringre.
-
Delila_1
veterán
Érvényesítésben add meg a két választható elemet.
A feltételes formázásnál erre a cellára kell hivatkoznod. Ha pl. a B oszlopban van az érvényesítés, az adatok meg A2-től Q1000-ig, akkor kijelölöd a teljes területet. A feltételes formázáshoz 2 képletet vigyél be.
=$B2="igen" és =$B2="nem". A két képlethez külön add meg a két háttérszínt. Fontos a $ jel az érvényesítést tartalmazó oszlop betűjele előtt. -
-
#21733
Delila_1
veterán
ritterkrisz
#21729
Delila_1
veterán
válasz
ritterkrisz
#21729
üzenetére
Másik megoldás, hogy felveszel ideiglenes egy segédoszlopot, ahol a képlet
="product/" & D2
Ezt végig másolod. Kijelölöd a képletet tartalmazó cellákat, Ctrl+c-vel másolod, beállsz a D2 cellába, jobb klikk, Irányított beillesztés, Értéket. A segédoszlopot törölheted.
-
Delila_1
veterán
válasz
slashing
#21728
üzenetére
Meg kell szüntetned az összevonásokat az A oszlopban, mert emiatt nem tudsz autoszűrővel szűrni. Nézz el ide. Ezután már nincs szükség az I:K celláira, helyben tudsz szűrni.
Hogy ne legyenek zavaróak az A oszlop ismétlődő adatai, az A3 cellától lefelé vigyél be feltételes formázást. A képlete =A3=A2, és a karakter színének add meg a cellák háttérszínét.
A feltételes formázás első egyenlőségjelét HA szóként kell értelmezni. Itt: ha az aktuális cella tartalma megegyezik a fölötte lévővel, akkor jöhet a formázás.
-
-
Delila_1
veterán
válasz
KERO_SAN
#21719
üzenetére
Tényleg nem egészen világos, mit szeretnél. Nem tudom, mitől függ, hogy a 2. táblázatban melyik az a bizonyos n-edik sor.
Szerintem az 1. táblázathoz vegyél fel egy új oszlopot, ami a dátumok hónapját adja a
=HÓNAP(A2) függvénnyel. Akkor egyszerű a szűrés ebben az új oszlopban. -
Delila_1
veterán
válasz
KERO_SAN
#21716
üzenetére
Szűröd az A oszlopot. A táblázaton kívül egy üres cellába, pl. a Z1-be (ha az üres), beírod a függvényt.
=RÉSZÖSSZEG(9;B:B)
A másik lapra, ahol a mindenkori részösszeget akarod megjeleníteni, ennyit írsz: =Munka1!Z1
Természetesen a Munka1 helyett a saját lapod nevét írd be. -
Delila_1
veterán
válasz
Gabcsika
#21708
üzenetére
Itt a manuális nyomtatáshoz a makró, bár nálam hiba nélkül végrehajt mindent.
Sub Nyomtat()
Dim sor1 As Long, sor2 As Long
Sheets("Sheet2").Cells.ClearContents
Sheets("Sheet1").Select
If Range("V1") = "" Then Range("V1") = 2
sor1 = Range("V1"): sor2 = 1
Do While sor2 <= 66
Range("A" & sor1 & ":C" & sor1 + 4).Copy
Sheets("Sheet2").Range("A" & sor2).PasteSpecial Paste:=xlPasteValues, Transpose:=True
sor1 = sor1 + 5
sor2 = sor2 + 3
Loop
Range("V1") = sor1
Sheets("Sheet2").Select
MsgBox "Nyomtass"
If Application.CountA(Sheets("Sheet1").Columns(1)) < sor1 Then _
Sheets("Sheet1").Range("V1") = ""
End Sub -
#21707
Delila_1
veterán
atillaahun
#21703
Delila_1
veterán
válasz
atillaahun
#21703
üzenetére
Igen, a csere funkcióval, minden ékezetesre külön.
-
-
Delila_1
veterán
válasz
Gabcsika
#21699
üzenetére
Másol, kinyomtatja az első átmásolt mennyiséget, törli a Sheet2 lap tartalmát, másolja és nyomtatja a következőt. Ezt addig folytatja, míg a Sheet1 lapon talál adatot
Az utolsó adagot az én hibám miatt nem nyomtatja. Az eredeti makró Loop sora alá másold be:
If Sheets("Sheet2").Range("A1") > "" Then
Sheets("Sheet2").Select
ActiveWindow.ActiveSheet.PrintOut Copies:=1, Collate:=True
Cells.ClearContents
Sheets("Sheet1").Select
End If -
Delila_1
veterán
válasz
Gabcsika
#21692
üzenetére
Próbáld meg ezzel a makróval.
Sub Nyomtat()
Dim sor1 As Long, sor2 As Long
Sheets("Sheet1").Select
sor1 = 2: sor2 = 1
Do While Cells(sor1, "A") <> ""
Range("A" & sor1 & ":C" & sor1 + 4).Copy
Sheets("Sheet2").Range("A" & sor2).PasteSpecial Paste:=xlPasteValues, Transpose:=True
sor1 = sor1 + 5
If sor2 >= 63 Then
Sheets("Sheet2").Select
ActiveWindow.ActiveSheet.PrintOut Copies:=1, Collate:=True
Cells.ClearContents
Sheets("Sheet1").Select
sor2 = 1
Else: sor2 = sor2 + 3
End If
Loop
End Sub -
Delila_1
veterán
válasz
alfa20
#21675
üzenetére
A Page2 azonos a beillesztett képpel, csak az objektumok neve más.
Private Sub CommandButton1_Click()
If OptionButton1_1 Then
OB1_1
ElseIf OptionButton1_2 Then OB1_2
Else: MsgBox "Mi lesz?"
End If
End Sub
Private Sub CommandButton2_Click()
If OptionButton2_1 Then
OB2_1
ElseIf OptionButton2_2 Then OB2_2
Else: MsgBox "Mi lesz?"
End If
End Sub
Sub OB1_1()
MsgBox "OB1_1"
End Sub
Sub OB1_2()
MsgBox "OB1_2"
End Sub
Sub OB2_1()
MsgBox "OB2_1"
End Sub
Sub OB2_2()
MsgBox "OB2_2"
End Sub -
#21656
Delila_1
veterán
atillaahun
#21655
Delila_1
veterán
válasz
atillaahun
#21655
üzenetére
Szívesen.
-
#21654
Delila_1
veterán
atillaahun
#21652
Delila_1
veterán
válasz
atillaahun
#21652
üzenetére
C1-be
=HA(DARABTELI(B:B;B1)>1;SZUMHA(B:B;B1;A:A);"") -
#21644
Delila_1
veterán
anonymus89
#21643
Delila_1
veterán
válasz
anonymus89
#21643
üzenetére
Na és mi ezzel a baj?
-
#21642
Delila_1
veterán
anonymus89
#21641
Delila_1
veterán
válasz
anonymus89
#21641
üzenetére
-
#21640
Delila_1
veterán
anonymus89
#21639
Delila_1
veterán
válasz
anonymus89
#21639
üzenetére
Ha valamelyik adatsort a második Y tengelyhez rendeled, a két oszlop egymást fedi. Kijelölöd az egyik oszlop tartományt, és szélesebbre veszed (a közt kisebbre állítod), és már látszik is minden adatod.
-
#21593
Delila_1
veterán
PindurAnna
#21592
Delila_1
veterán
válasz
PindurAnna
#21592
üzenetére
Kijelölöd a formázandó területet. A formázás képlete
=JOBB($A1;2)<>BAL($B1;2)
-
Delila_1
veterán
válasz
bandus
#21587
üzenetére
mit = Range("a5")
Columns("A:A").Find(What:=mit, After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Select
MsgBox Selection.RowSzerk.: itt a keresés végén a Select utasítást látod. Erre azért van szükség, hogy utána le tudd kérdezni a pozícióját. Előtte az A oszlopot jelölted ki, Activate utasítással 1-et írna a találat sorának.
-
-
Delila_1
veterán
válasz
bandus
#21584
üzenetére
Az egyszerűség kedvéért a keresést rögzítéssel vettem fel. utólag vettem észre, hogy nem állítottam le a rögzítést. A makró csak ennyi:
Sub Keres()
Dim tofind As Date, sor As Long, oszlop As Long
tofind = Range("A3")
Sheets("FEL").Select
Cells.Find(What:=tofind, After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Activate
sor = Selection.Row
oszlop = Selection.Column
MsgBox "Sor: " & sor & vbLf & "Oszlop: " & oszlop
End Sub -
Delila_1
veterán
válasz
ildikol
#21577
üzenetére
Az a gyanúm, hogy nem pontosan másoltad a makrót. A
Cells(Target.Row, "Q") = Time sor határozza meg a beírandó MOST() függvény helyét.Képet akarsz betenni? Annak nincs sok értelme. Tedd ki a fájlt egy elérhető helyre, de előbb a nem publikus adatok helyett írj bele kamu értékeket.
-
Delila_1
veterán
válasz
ildikol
#21575
üzenetére
Töröld ki az If Target.Column = 16 Then sort, és a hozzá tartozó utolsót, az End If-et.
Lesz egy káros hatása. Ahányszor beírsz valamit az első lapra, annak a sorát átmásolja egy új sorba a másik lapra. Mire kitöltöd a teljes sort (A-tól P-ig), 16 új sorod lesz a másoltakat tartalmazó lapon.
-
#21570
Delila_1
veterán
littleNorbi
#21569
Delila_1
veterán
válasz
littleNorbi
#21569
üzenetére
Nincs mit.
-
#21568
Delila_1
veterán
kerteszke3
#21567
Delila_1
veterán
válasz
kerteszke3
#21567
üzenetére
Örülök neki, szívesen.
-
#21566
Delila_1
veterán
kerteszke3
#21565
Delila_1
veterán
válasz
kerteszke3
#21565
üzenetére
Tömbképlet! beírod a képletet a kapcsos zárójelek nélkül, majd a szerkesztőlécen állva Shift+Ctrl+Enterrel viszed be.
{=DARAB(HA((A1:A5)=(B1:B5);B1:B5))}
-
#21561
Delila_1
veterán
lazlogogola
#21558
Delila_1
veterán
válasz
lazlogogola
#21558
üzenetére
Küldd el a két fájlt, privátban megadom a címet.
-
#21556
Delila_1
veterán
sutyimatyi
#21554
Delila_1
veterán
válasz
sutyimatyi
#21554
üzenetére
Nem látom át, miket számolsz. Van kezdési idő, de nincs végzés.
Mondd meg a főnöknek, hogy neki is könnyebb lefelé görgetni, mint oldalra. Mindig azt tesszük a sorokba, amiből több van. Itt a napokból max. 31 van, ráadásul naponként 3 adatot kell látni. Fordított elrendezésnél minden adat látszik az oszlopokban.
-
#21553
Delila_1
veterán
lazlogogola
#21544
Delila_1
veterán
válasz
lazlogogola
#21544
üzenetére
Látatlanban arra gondolok, hogy a forrásban nem az A1-ben kezdődnek az adataid.
-
#21551
Delila_1
veterán
sutyimatyi
#21545
Delila_1
veterán
válasz
sutyimatyi
#21545
üzenetére
A helyedben elfordítanám 90°-kal a táblázatot.
-
Delila_1
veterán
válasz
gobe22
#21548
üzenetére
Az üres sorok törlésével kezd, nem szükséges a kijelölés, azonnal futtatható. Feltételezem, hogy a txt fájlból az adatokat az A1-től kezdve másolod be.
Sub VizszRend()
Dim usor As Long, sor As Long
Application.DisplayAlerts = False
'Üres sorok törlése
Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
'Szövegből oszlopok
usor = Application.CountA(Columns(1))
Range("A1:A" & usor).TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1)), _
TrailingMinusNumbers:=True
'Rendezés soronként
For sor = 1 To usor
Rows(sor).Select
Selection.Sort Key1:=Range("A" & sor), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlLeftToRight, _
DataOption1:=xlSortNormal
Next
'Összefűzés az N oszlopban
Range("N1:N" & usor).FormulaR1C1 = _
"=RC[-13]&"",""&RC[-12]&"",""&RC[-11]&"",""&RC[-10]&"",""&RC[-9]&"",""&RC[-8]&"",""&RC[-7]&"",""&RC[-6]&"",""&RC[-5]&"",""&RC[-4]&"",""&RC[-3]&"",""&RC[-2]"
'N oszlop irányított beillesztése az A-ba
Range("N:N").Copy
Range("A1").PasteSpecial xlPasteValues
'Segédoszlopok törlése
Range("B:N").ClearContents
'Többszörös vesszők törlése
sor = 0
Do While sor < 3
Cells.Replace What:=",,", Replacement:="", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
sor = sor + 1
Loop
'Utolsó vessző törlése képlettel a H oszlopba
Range("H1:H" & usor).FormulaR1C1 = _
"=IF(RIGHT(RC[-7],1)="","",LEFT(RC[-7],LEN(RC[-7])-1),RC[-7])"
'H oszlop másolása az A-ba
Range("H:H").Copy
Range("A1").PasteSpecial xlPasteValues
Range("H:H").ClearContents 'H oszlop törlése
Application.DisplayAlerts = False
End Sub -
Delila_1
veterán
válasz
gobe22
#21543
üzenetére
Kicsit sok volt a buktató.
Kijelölöd a tartományt az A oszlopban, és indítod a makrót.Sub VizszRend()
Dim usor As Long, sor As Long
Application.DisplayAlerts = False
'Szövegből oszlopok
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1)), _
TrailingMinusNumbers:=True
'Rendezés soronként
usor = Application.CountA(Columns(1))
For sor = 1 To usor
Rows(sor).Select
Selection.Sort Key1:=Range("A" & sor), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlLeftToRight, _
DataOption1:=xlSortNormal
Next
'Összefűzés az N oszlopban
Range("N1:N" & usor).FormulaR1C1 = _
"=RC[-13]&"",""&RC[-12]&"",""&RC[-11]&"",""&RC[-10]&"",""&RC[-9]&"",""&RC[-8]&"",""&RC[-7]&"",""&RC[-6]&"",""&RC[-5]&"",""&RC[-4]&"",""&RC[-3]&"",""&RC[-2]"
'N oszlop irányított beillesztése az A-ba
Range("N:N").Copy
Range("A1").PasteSpecial xlPasteValues
'Segédoszlopok törlése
Range("B:N").ClearContents
'Többszörös vesszők törlése
sor = 0
Do While sor < 3
Cells.Replace What:=",,", Replacement:="", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
sor = sor + 1
Loop
'Utolsó vessző törlése képlettel a H oszlopba
Range("H1:H" & usor).FormulaR1C1 = _
"=IF(RIGHT(RC[-7],1)="","",LEFT(RC[-7],LEN(RC[-7])-1),RC[-7])"
'H oszlop másolása az A-ba
Range("H:H").Copy
Range("A1").PasteSpecial xlPasteValues
Range("H:H").ClearContents 'H oszlop törlése
Application.DisplayAlerts = False
End Sub -
#21541
Delila_1
veterán
lazlogogola
#21539
Delila_1
veterán
válasz
lazlogogola
#21539
üzenetére
Nem kell lista.
A betegek kr.xls-be írd be a képletet oda, ahova másolni akarsz.
=[2másolat.xls]krónikus!A1 ha a lap neve, ahonnan másolni akarsz, krónikus.
A képletet lemásolod a 300. sorig. -
#21537
Delila_1
veterán
lazlogogola
#21535
Delila_1
veterán
válasz
lazlogogola
#21535
üzenetére
Igen, a fájl nevét kiterjesztéssel, majd annak a lapnak a nevét, ahonnan másolsz.
A képletet lemásolva a többi sorban megkapod a 300 adatot. -
Delila_1
veterán
válasz
gobe22
#21530
üzenetére
Több lépésben lehet megoldani.
1. Kijelölöd a tartományt, a Szövegből oszlopok funkcióval oszlopokra bontod a szöveget, ahol határoló jelnek a vesszőt jelölöd be.
2. Újra kijelölöd a kibővült tartományt, Rendezés. Itt az Egyebek-nél a Balról jobbra funkciót választod.
3. Ezután újra összefűzöd az adatokat egy segédoszlopban, közöttük vesszővel: =A1 & "," & B1 & "," & C1 stb., ahány oszlopra bontotta szét a Szövegből oszlopok.
4. A segédoszlopot másolod, és az eredeti helyére illeszted be irányítottan, értékként.
5. Törlöd a feleslegessé vált oszlopokat, csak az A maradjon meg.
oszlopot adom meg, akkor a tartományt fixen kell megadni, erre szolgálnak a $ jelek.
Új hozzászólás Aktív témák
Fferi50- Hosszú premier előzetest kapott az Arknights: Endfield
- CURVE - "All your cards in one." Minden bankkártyád egyben.
- Vezeték nélküli fülhallgatók
- Milyen külső akkumulátort mobileszközökhöz?
- Kormányok / autós szimulátorok topikja
- Facebook és Messenger
- Meghozta a régóta várt asztali Ryzen APU-kat az AMD
- Spórolós topik
- Bittorrent topik
- E-roller topik
- További aktív témák...
- Játékkulcsok ! : PC Steam, EA App, Ubisoft, Windows és egyéb játékok
- Windows, Office licencek kedvező áron, egyenesen a Microsoft-tól - Automata kézbesítés utalással is!
- Windows 10 11 Pro Office 19 21 Pro Plus Retail kulcs 1 PC Mac AKCIÓ! Automatikus 0-24
- PC Game Pass előfizetés
- Microsoft és egyéb dobozos retro szoftverek
- Telefon felvásárlás!! Huawei P20 Lite/Huawei P20/Huawei P30 Lite/Huawei P30/Huawei P30 Pro
- Egérpadok, billentyűsapkák(keycapek), csuklótámaszok /ARCANE/DUCKY/GLORIOUS/
- Yoga Pro 9 - RTX 5070 - 64GB - multitouch laptopok! - LENOVO GAMER BAZÁR - új lista (2026.03.03)
- AKCIÓ! LENOVO ThinkPad P15 Gen2 munkaállomás - i7 11800H 32GB DDR4 1TB SSD RTX A2000 4GB W
- Telefon felvásárlás!! iPhone 12 Mini/iPhone 12/iPhone 12 Pro/iPhone 12 Pro Max
Állásajánlatok
Cég: Laptopműhely Bt.
Város: Budapest