Hirdetés
- sziku69: Fűzzük össze a szavakat :)
- Luck Dragon: Asszociációs játék. :)
- GoodSpeed: A RAM-válság és annak lehetséges hatásai
- eBay-es kütyük kis pénzért
- D1Rect: Nagy "hülyétkapokazapróktól" topik
- f(x)=exp(x): A laposföld elmebaj: Vissza a jövőbe!
- gban: Ingyen kellene, de tegnapra
- GoodSpeed: Márkaváltás sok-sok év után
- D@reeo: Pi-hole és a Telekom Sagemcom F@st 5670 DNS beállítása
- Mr Dini: Mindent a StreamSharkról!
-
LOGOUT
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
-
Mutt
senior tag
Szia,
Kösz a pontosítást. Félreértelmeztem a dolgot, a makró ez esetben egyszerűbb mivel az első oszlopban van egy azonosító rész (a pont előtti), ami alapján egybe kell tenni az adatokat.
A run-time error-t azért kapod, mert a makró úgy működik hogy előbb kijelölöd egérrel azt a részt ahol a bemeneti adatok vannak és utána indítod el.
A
Set adatsor = Intersect(Selection, ActiveSheet.UsedRange)részben a Selection jelenti az általad kijelölt tartományt, az Activesheet... pedig az összes tartományt jelenti ahol van adat. Ha fix helyen van a bementi adatod (pl. B1-es cellától indulva lefelé),
akkorSet adatsor = Range("B1").CurrentRegionműkődik.Option ExplicitSub Transzponalas()Dim adatsor As RangeDim adatok()'tegyük a kijelölt bemeneti adatokat egy tömbbeSet adatsor = Intersect(Selection, ActiveSheet.UsedRange)adatok = adatsor'kérdezzük meg hova kerüljön az eredményDim cel As RangeSet cel = Application.InputBox(Prompt:="Add meg hova kerüljön az eredmény!", Title:="Információ", Type:=8).Range("A1")'nézzük meg nem írjuk-e felül a bemeneti tartománytIf Not Intersect(adatsor, cel) Is Nothing ThenCall MsgBox(Prompt:="A cél terület beleér a bemenő adatokat tartalmazó tartományba", Buttons:=vbOKOnly, Title:="Hiba")Exit SubEnd If'ebbe a tömbbe fogjuk gyűjteni az eredménytDim kimenet()ReDim kimenet(1 To 2)Dim x As LongDim azonosito As String, fsplitDim v_sor As Longv_sor = 0With cel.ParentFor x = 1 To UBound(adatok, 1)'a legelőször látott értékeket eltároljukIf x = 1 Thenkimenet(1) = adatok(x, 1)kimenet(2) = adatok(x, 2)'szakasz azonosító meghatározása referenciáhozfsplit = Split(kimenet(1), ".")azonosito = fsplit(0)Else'aktuális sorban keressük meg a szakasz azonosítótfsplit = Split(adatok(x, 1), ".")'ha azonos mint az előző, akkor'1) hozzáadjuk a kimeneti tömbhöz az értékeketIf fsplit(0) = azonosito ThenReDim Preserve kimenet(1 To UBound(kimenet) + 2)kimenet(UBound(kimenet) - 1) = adatok(x, 1)kimenet(UBound(kimenet) - 0) = adatok(x, 2)Else'ha nem azonos a szakasz azonosító, akkor'1) kiírjuk a "kimenet"-et'2) növeljük a sorszámot ahova az eredményeket tesszük'3) töröljük a "kimenet" tartalmát'4) elmentjük az új szakasz azonosítótcel.Offset(v_sor).Resize(, UBound(kimenet)) = kimenetv_sor = v_sor + 1ReDim kimenet(1 To 2)kimenet(1) = adatok(x, 1)kimenet(2) = adatok(x, 2)azonosito = fsplit(0)End IfEnd IfNext x'ha a ciklus végén maradt vmi a tömbben írjuk kiIf kimenet(1) <> "" Thencel.Offset(v_sor).Resize(, UBound(kimenet)) = kimenetEnd IfEnd WithEnd SubMS365-ben vannak újabb függvények, amelyek tudnak segíteni.
A képlet:=LET(adatok;A1:B20;kodok;OSZLOPVÁLASZTÁS(adatok;1);azonositok;EGYEDI(SZÖVEGELŐTTE(kodok;"."));csoportok;REDUCE("";azonositok;LAMBDA(a;c;FÜGG.HALMOZÁS(a;SZÖVEGFELOSZTÁS(SZÖVEGÖSSZEFŰZÉS("|";IGAZ;SZŰRŐ(adatok;SZÖVEGELŐTTE(kodok;".")=c));"|"))));HAHIBA(ELTÁVOLÍT(csoportok;1);""))
Hogyan működik?
1) LET-el változókat lehet a képletben létrehozni és azokkal műveleteket végezni. Az első paraméter a változó neve és utána egy művelet, pl. "adatok" a változó neve és utána a "A1 : B20" a tartomány ahonnan kellenek az adatok. A LET-ben az utolsó paraméter egy művelet, aminek az eredményét kiírja az Excel.
2) Szóval bemeneti adatok első oszlopából csináltam egy listát, amely a pont előtti részeket visszaadja minden sorra ("F1-01", ... "F1-02"), és ebből csak az egyedi értékeket tartottam meg (ez kerül be az "azonositok" változóba).
3) Ezek után a SZŰRŐ függvénnyel az eredeti adatsorból kinyerem az egyik azonosítóhoz tartozó értékeket. Az eredményt egy sorba kell tenni, itt jön az a trükk hogy előbb összefűzzük az elemeket egy cellába olyan elválasztó jellel, ami nincs az adatsorban, majd ezt ugyanezen elválasztó jel szerint feldaraboljuk. Belül van a SZÖVEGÖSSZEFŰZÉS ahol a "|" (pipe) jelet használtam elválasztónak, és kívül van a SZÖVEGFELOSZTÁS szintén pipe-al.
4) A REDUCE függvény segít abban hogy a 3-as lépésben lévő szűrést mindegyik azonosítóval megcsináljam. Mindegyik szűrés eredményét egymásra teszem (függőleges halmozás).
5) Csinosítani kell a végeredményt, mert nem minden sorban lesz ugyanannyi oszlop.üdv
-
Mutt
senior tag
Szia,
Késő este ezt hoztam össze neked.
Option ExplicitSub Transzponalas()Dim adatsor As RangeDim adatok()'tegyük a kijelölt bemeneti adatokat egy tömbbeSet adatsor = Intersect(Selection, ActiveSheet.UsedRange)adatok = adatsor'kérdezzük meg hova kerüljön az eredményDim cel As RangeSet cel = Application.InputBox(Prompt:="Add meg hova kerüljön az eredmény!", Title:="Információ", Type:=8).Range("A1")'nézzük meg nem írjuk-e felül a bemeneti tartománytIf Not Intersect(adatsor, cel) Is Nothing ThenCall MsgBox(Prompt:="A cél terület beleér a bemenő adatokat tartalmazó tartományba", Buttons:=vbOKOnly, Title:="Hiba")Exit SubEnd If'ebbe a tömbbe fogjuk gyűjteni az eredménytDim kimenet()ReDim kimenet(1 To 2)Dim x As LongDim utolso_ertek As DoubleDim temp1, temp2Dim v_sor As Longv_sor = 0With cel.ParentFor x = 1 To UBound(adatok, 1)'a legelőször látott értékeket eltároljukIf x = 1 Thenkimenet(1) = adatok(x, 1)utolso_ertek = adatok(x, 2)kimenet(2) = utolso_ertekElse'adjuk hozzá a további értékeket, ehhez terjesszük ki a tömbbötReDim Preserve kimenet(1 To UBound(kimenet) + 2)kimenet(UBound(kimenet) - 1) = adatok(x, 1)kimenet(UBound(kimenet) - 0) = adatok(x, 2)'ha a korábban tároltnál nagyobb értéket látunk, akkor tegyük az alábbiakat'1) levágjuk a "kimenet" utolsó 2 elemét és eltároljuk őket'2) kiírjuk a "kimenet"-et'3) növeljük a sorszámot ahova az eredményeket tesszük'4) töröljük a "kimenet" tartalmát és beletesszük az 1-es lépésben tárolt értékeketIf adatok(x, 2) > utolso_ertek Thentemp1 = kimenet(UBound(kimenet) - 1)temp2 = kimenet(UBound(kimenet) - 0)ReDim Preserve kimenet(1 To UBound(kimenet) - 2)cel.Offset(v_sor).Resize(, UBound(kimenet)) = kimenetv_sor = v_sor + 1ReDim kimenet(1 To 2)kimenet(1) = temp1kimenet(2) = temp2utolso_ertek = temp2Elseutolso_ertek = adatok(x, 2)End IfEnd IfNext x'ha a ciklus végén maradt vmi a tömbben írjuk kiIf kimenet(1) <> "" Thencel.Offset(v_sor).Resize(, UBound(kimenet)) = kimenetEnd IfEnd WithEnd SubAdtam hozzá megjegyzéseket.
Amit én gondoltam végig, hogy a második oszlopban ha egy nagyobb számot látunk mint az előző sorban, akkor az előző sorig látott dolgokat ki kell írni és egy új sorba kell tenni majd az adatokat amíg megint találunk egy nagyobb számot mint az előző sorban.A kód egy tömbbe elkezdi gyűjteni az adatokat és ha jön a feltétel, akkor a tömb utolsó két elemét kivéve kiírjuk az addigi tartalmat. A tömböt nullázuk az aktuális sorban levő értékeket újra beletesszük és megyünk tovább. Közben mindig elmentjük egy változóba a második oszlop értékét.
A kódban ami haladó VBA dolog:
1) tömbök menetközbeni átméretezése (ReDim)
2) tömbök tartalmának munkalapra kiírása (cel.Offset(v_sor).Resize(, UBound(kimenet)) = kimenet)Szerintem makró nélkül is megoldható a feladat. Power Query vagy az újabb Excel függvényekkel (LET és FÜGG.HALMOZÁS). Próbáljuk meg azt is?
üdv
-
Fferi50
Topikgazda
Szia!
Szerintem ebben a szerkezetben sajnos nem lehet xml-be visszaexportálni excelből, több akadály miatt is. Nem normalizált a táblázat, lista szerepel benne, több származtatott gyermek is van.
Viszont szövegfájlként el lehet menteni, persze akkor az XML jelölések elvesznek belőle.
Üdv. -
Fferi50
Topikgazda
Szia!
Nézted már az XML - lel kapcsolatos Excel súgót?
Tanulmányozgatom, hátha tudok valamit segíteni. Megnyitni már megnyitja, de XML-ben nem lehet exportálni, mert nem exportálható az automatikusan létrehozott séma.
Talán először létre kellene hozni egy érvényes XML sémát és utána importálni.
Üdv. -
-
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. -
Mutt
senior tag
Szia,
Mivel új Exceled van én is bedobom a megoldásomat, ami az új makrónyelvet (OfficeScript) használja.
Telepítened kell az ingyenes Script Lab bővítményt az Office-bővítmények áruházból. Majd azt elindítva importáld be a kódot ezen linkről:
https://gist.github.com/viszi/0a28b84dbece74b23219923a3e963b64Utána pedig mehet a futtatás.
Előnye, hogy a munkafüzet továbbra is makrómentes maradhat, mivel a makró nem kerül oda be.
Hátránya, hogy még nekem is tanulnom kell az új nyelvezetet.üdv
-
Fferi50
Topikgazda
Szia!
Csinálj egy segédoszlopot, aminek a képlete:
=HA(A3="";H2;A3)
Ezt végighúzod.
Ezután egy második segédoszlopba írd a következő képletet:
=HA(H3=H4;B3 & "!" & I4; B3)
(A felkiáltójel az összefűzött értékek "szétválasztója", helyette mást is írhatsz).
Ezt is végighúzod az oszlopon, itt egy részlet az eredményből:
A két segédoszlopot kijelölöd - másolás, irányított beillesztés - értéket.
Ezután az A oszlopra teszel egy szűrőt - kiválasztod az üreseket. Kitörlöd a sorokat.
Majd a 2. segédoszlop értékeit átmásolod a B oszlopba.
Ezután a 2 segédoszlop törölhető.
Eredmény:
Üdv.
-
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.
-
Mutt
senior tag
Szia,
...nem feltétlenül a megoldás kell, hanem szeretném megtanulni, hogy bármilyen felmerülő problémát meg tudjak oldani...
Sok feladat megoldható összetett képletekkel vagy az újabb Excelekben elérhető funkciókkal.
1. Ha esetleg még nem dolgoztál tömbfüggvényekkel, akkor érdemes velük kezdeni. Segít az Excel magabiztos használatában és olyan helyeken/esetekben hasznos ahol a makró nem járható út.
Youtubeon Mike Girvin szokott régen szép megoldásokat bemutatni.2. Hasznos bővítmény a Power Pivot, ami a DAX formulákat adta az Excelhez és a Power Query ami az M-nyelvet. Az előbbi kezd háttérbe szorulni az utóbbi miatt, de érdemes rájuk nézni. Ha nagyobb mennyiségű adattal kell dolgozni, elemzéseket kell készíteni akkor ezek a legjobb eszközök. A Power Query számos olyan funkciót hozott amelyek korábban csak VBA-val ment, szerintem manapság haladó Exceles nem kerülgetheti.
Youtubeon megint csak Mikeot tudom javasolni.Az Office365-el új írányt vett a Microsoft, az online/megosztásos munka új megoldásokat kívánt és ezeket próbálja meg orvosolni a cég. A makró nyelv régóta megvan az Excel-ben; a 4.0-ás makrókat - ha jól emlékszem -1995-ben VBA-ra cserélte a Microsoft, de még a mai napig támogatott a 4.0 makró is. Excel 2013-al pedig jött az újabb nyelv, ami JavaScript alapú. Az új nyelv előnye lesz, hogy az online változatban is használható lesz, de még mindig fejlesztési álapotban van és csak a bátraknak javasolt. A VBA még jó sok évig az asztali változatokban valószínűleg támogatott lesz, de az online-t már csak az új nyelvvel lehet feltuningolni.
Jelenleg is érdemes VBA-t tanulni (angol nyelven John Walkenbach szerintem jó könyveket adott ki, illetve Youtubeon is számos videot találsz vmint a makrórgzítő eredményét is lehet nézegetni). Azonban a JavaScript univerzálisabb nyelv, így ha van energiád érdemes azzal is foglalkozni. A gond hogy az Office JavaScript nyelvről még nincs jó könyv, marad a hivatalos és száraz dokumentáció vmint sok-sok próbálkozás illetve mások kódjának nézegetése. A másik előny, hogy a Google Apps Script is JavaScript alapon nyugszik, így az itt megtanultak ott is tudnak segíteni.
üdv
-
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 -
Mutt
senior tag
Szia,
VBA-s megoldást kaptál, de mivel Office365-öd van egy másik megoldás is, ami az új makró nyelvet használja.
1. Telepítsd az Office áruházból a Script Lab bővítményt.
2. Kattints a Scrip Lab menűben a Code gombra.
3. A hamburger menüben válaszd az Import opciót és add meg ezt a linket: https://gist.github.com/viszi/e2bd0fe97f1cd3794ea2402c90d40914
4. Betöltés után kattints a Run -> Run in this pane-re (feltéve ha már megnyitottad az átalakítandó fájlt).
Majd pedig az indítás gombra.Ebben a változatban én meghagytam a díjak mértékegységét, ha nincs rá szükséged akkor a Code gomb alatt a 23-as sort (
cel.getCell(i, 2).values = result[0][2];) töröld ki.Remélem nálad is műkődik.
üdv
-
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
Úgy látom, állandó változásban van szegény makró. A másolás sorai
ide = Sheets(lapnev).Range("B" & Rows.Count).End(xlUp).Row + 1
Sheets("Munka2").Range("A" & sor & ":F" & sor).Copy Sheets(lapnev).Range("B" & ide)
Sheets("Munka2").SelectMár csak azt kell megmondanod, hogy az A: F tartományt a másik lap A-ba, vagy B-be tegye. Ha A-ba, akkor
Sheets("Munka2").Range("A" & sor & ":F" & sor).Copy Sheets(lapnev).Range("A" & ide)
kell neked. -
Delila_1
veterán
"ezután megvizsgálja a "munka2" lap A3 celláját és ha van olyan nevű munkalap már, akkor a B oszlop következő sorába bemásolja a tartalmát, ha nincsen a cellában szereplő nevű munkalap akkor létrehozza azt, és a B2 cellájába bemásolja a "munka2" lap A3-as
cellájának a tartalmát..."
Ebből nekem úgy tűnt, hogy az eredeti adat sorába kell másolni a B oszlop tartalmát.
Beteszek egy képet, kiemelve a módosításokat.
-
#42893
Fire/SOUL/CD
félisten
Sesy
#42875
Akkor még egy megoldás, csak a változatosság kedvéért...
Alaphelyzet
Makró futtatása után (Start Macro gomb)
1. új munkalap | 2. új munkalap | 3. új munkalap
Létrehozott munkalapok törlése után (Delete Created Sheets gomb)Macro forráskód
Option Explicit
'Globális deklarációk
Dim MySrcRange, MyTempRange, MyCell As Range
Dim MySheetNamesArray() As String
Dim MySheetNamesIndexArray() As Long
Dim MyArrayIndex, MyDestOffset As Long
Dim MySrcSheetName, MySrcCodesColumn, MySrcCodesRow, MyDestCodesColumn, MyDestCodesRow As String
Private Sub CommandButton1_Click()
'Képernyő frissítés KI
Application.ScreenUpdating = False
'Forrás munkalap és cella beállítása
MySrcSheetName = "Munka2"
MySrcCodesColumn = "A"
MySrcCodesRow = "2"
'Cél cella beállítása
MyDestCodesColumn = "B"
MyDestCodesRow = "2"
'Forrás munkalap kiválasztása
ThisWorkbook.Worksheets(MySrcSheetName).Select
'Tartomány létrehozása a forrás adatok alapján
Set MySrcRange = Range(MySrcCodesColumn & MySrcCodesRow & ":" & MySrcCodesColumn & Cells(Cells.Rows.Count, MySrcCodesColumn).End(xlUp).Row)
'Dinamikus tömbők átméretezése a tartományban található cellák száma alapján (üreseket is beleértve)
ReDim MySheetNamesArray(0 To MySrcRange.Count - 1)
ReDim MySheetNamesIndexArray(0 To MySrcRange.Count - 1)
MyArrayIndex = 0
'Végignézzük a forrástartomány használt celláit
For Each MyCell In MySrcRange
'Ha üres, akkor kihagyjuk
If Not IsEmpty(MyCell) Then
'Aktuális munkalap létezik?
If Not SheetExists(MyCell.Text) Then
'Nem létezik, létrehozzuk és beírjuk a forráscella értékét
ActiveWorkbook.Sheets.Add After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count)
ActiveSheet.Name = MyCell.Text
Sheets(ActiveSheet.Name).Range(Cell1:=MyDestCodesColumn & MyDestCodesRow) = MyCell.Text
'Létrehozott munkalap nevét beírjuk a tömb megfelelő pozíciójába és megnöveljük a tömb indexét
MySheetNamesArray(MyArrayIndex) = MyCell.Text
MySheetNamesIndexArray(MyArrayIndex) = MySheetNamesIndexArray(MyArrayIndex) + 1
MyArrayIndex = MyArrayIndex + 1
Else
'Létezik, meghatározzuk a célcella eltolási értékét és beírjuk a forráscella értékét
MyDestOffset = GetDestRangeOffsetAsSheetName(MyCell.Text)
Sheets(MyCell.Text).Range(Cell1:=MyDestCodesColumn & (MyDestCodesRow + MySheetNamesIndexArray(MyDestOffset))) = MyCell.Text
'Eltolási értéket megnöveljöük az eltolási értékeket tartalmazó tömbben
MySheetNamesIndexArray(MyDestOffset) = MySheetNamesIndexArray(MyDestOffset) + 1
End If
End If
Next MyCell
'Forrás munkalap kiválasztása
ThisWorkbook.Worksheets(MySrcSheetName).Select
'Képernyő frissítés BE
Application.ScreenUpdating = True
'Start Macro gomb tiltása, Delete Created Sheets parancsgomb engedélyezése
CommandButton1.Enabled = False
CommandButton2.Enabled = True
End Sub
'Az adott munkalap létezik vagy nem
Public Function SheetExists(SheetName As String) As Boolean
Dim MyWorkSheet As Worksheet
Dim Result As Boolean
Result = False
For Each MyWorkSheet In ThisWorkbook.Sheets
If UCase(MyWorkSheet.Name) = UCase(SheetName) Then
Result = True
Exit For
End If
Next MyWorkSheet
SheetExists = Result
End Function
'A léterhozott munkalapon a cél cellák eltolási értékei
Public Function GetDestRangeOffsetAsSheetName(CurrentSheetName As String) As Long
Dim i As Long
For i = 0 To MySrcRange.Count - 1
If MySheetNamesArray(i) = CurrentSheetName Then
GetDestRangeOffsetAsSheetName = i
Exit For
End If
Next i
End Function
'A létrehozottt munkalapok törlése
Private Sub CommandButton2_Click()
Dim i As Long
'A megerősítő ablak(ok) megjelenésének tiltása
Application.DisplayAlerts = False
'Létrehozott munkalapok törlése
For i = 0 To MyArrayIndex - 1
If SheetExists(MySheetNamesArray(i)) Then Sheets(MySheetNamesArray(i)).Delete
Next i
'Forrás munkalap kiválasztása
ThisWorkbook.Worksheets(MySrcSheetName).Select
'A megerősítő ablak(ok) megjelenésének engedélyezése
Application.DisplayAlerts = True
'Start Macro gomb engedélyezése, Delete Created Sheets parancsgomb tiltása
CommandButton1.Enabled = True
CommandButton2.Enabled = False
End Sub -
-
-
Delila_1
veterán
Fferi gyorsabb volt, de azért én is beteszem a saját makrómat.
Sub Szetvalogatas()
Dim sor As Long, lapnev As String, usor As Long, a
usor = Range("A" & Rows.Count).End(xlUp).Row
For sor = 2 To usor
lapnev = Right(Cells(sor, 1), Len(Cells(sor, 1)) - 3)
On Error Resume Next
Set a = Sheets(lapnev)
If Err.Number > 0 Then
Sheets.Add.Name = lapnev
Sheets(lapnev).Move After:=Sheets.Count
End If
Sheets(lapnev).Cells(sor, 2) = Sheets("Munka2").Cells(sor, 2)
Sheets("Munka2").Select
Next
Sheets("Munka2").Move After:=Sheets(1)
MsgBox "Kész a szétválogatás", vbInformation
End Sub -
Fferi50
Topikgazda
Szia!
A "kulcsok" megfeleltetését egy táblázatba érdemes foglalni. Szerintem érdemes a formázást egy munkalapon manuálisan megcsinálni, utána pedig ezt lehet másolni.
Nálam a kódtábla ugyanazon a lapon van, ahol az adatok, és az alábbi makrót erről az aktív munkalapról kell indítani:Sub osztas()Dim sh As Worksheet, wb As Workbook, cl As Range, tabla As Range, klcs As String, mlapnev As String, sh1 As WorksheetSet sh = ActiveSheetSet tabla = Range("X1:Y100") 'itt van a kulcstáblaOn Error Resume NextFor Each cl In sh.UsedRange.Columns(1).Offset(1, 0).Cells 'az első oszlopon a 2. cellától megy végigIf cl.Value = "" Then Exit For 'üres cella esetén kilép a ciklusbólklcs = Left(cl.Value, 2) ' az első két karakter a kulcsmlapnev = tabla.Find(what:=klcs, LookIn:=xlValues, lookat:=xlWhole).Offset(0, 1).ValueIf Err = 0 Then ' ha megtaláltuk az értéket a kulcstáblában, akkorSet sh1 = Sheets(mlapnev)If Err = 9 Then ' ha még nincs ilyen nevű munkalapSheets("Sablon").Copy after:=Sheets(Sheets.Count) ' a Sablon nevű munkalapot másoljukSet sh1 = Sheets(Sheets.Count) ' és átnevezzüksh1.Name = mlapnevErr = 0End Ifsh1.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Value = cl.Value 'a B oszlop első üres cellájába másoljuk a cella értékétElse ' figyelmeztetés, hogy olyan kulcs van, amihez még nincs értékMsgBox "Ehhez a kulcshoz nincs név: " & klcs, vbInformationErr = 0 ' ezt az értéket figyelmen kívül hagyja és megy továbbEnd IfNextOn Error GoTo 0sh.ActivateMsgBox "kész vagyok", vbExclamationEnd Sub
A már meglevő munkalapokon az adatok nem íródnak felül, tehát ismételt feldolgozás esetén duplázódnak.
Ha kérdésed van, írj bátran.
Üdv. -
Fferi50
Topikgazda
Szia!
Már megint kérdésem van:
Ha számok vannak a munka2 lap A oszlopában, akkor honnan tudjuk, hogy mi a neve a keresendő munkalapnak? Mert csak számokat nem szerencsés munkalapnévnek adni.
A formázáshoz:
Egy munkalapot megformázol. Utána a formátum másolóval annyi munkalapra másolod, amennyire akarod. (Formátum másoló bekapcsolása kijelölöd a másolandó részt. Jobb egérgomb - a jobb oldalon levő ecsetre duplakatt. Addig marad bekapcsolva, amíg ESC-t nem nyomsz neki.)
De a megformázott munkalapot sablonként is elmentheted és nyithatsz utána ugyanolyan munkalapokat.
ÜDv. -
Delila_1
veterán
Egy rövid makró a 36 kezdetű cellák másolásához.
Sub Masolas()
Dim sor As Long, ide As Long
Sheets("Munka2").Select
sor = 1
Do While Cells(sor, 1) <> ""
If Left(Cells(sor, 1), 2) = "36" Then
ide = Sheets("Munka1").Range("A" & Rows.Count).End(xlUp).Row + 1 '***
Sheets("Munka1").Cells(ide, 1) = Cells(sor, 1).Value
End If
sor = sor + 1
Loop
End SubA csillagokkal jelzett sor határozza meg a Munka1 lapon az első üres sort.
Sok adat esetén érdemes a makró elején kikapcsolni a képernyő frissítését –Application.ScreenUpdating = False
–, a végén meg visszaállítani.
Szerk.: azt is megteheted, hogy szűröd az oszlopot a 36-os kezdetre, majd a szűrt állományt másolod a Munka1-re. -
Fferi50
Topikgazda
Szia!
Feltehetnél egy néhány sort tartalmazó mintát mind Excelből, mind Word-ből, benne azt is, hogy mit szeretnél elérni.
Mert így a sötétben adjuk a tanácsokat és úgy járunk, mint az egyszeri kádi, tanácsaink még lennének, de a libák elfogytak.
Természetesen nem kell valódi adat, csak "hasonlítson" a természete az eredetiekre.
Ebből össze tudnánk esetleg hozni azt az Excel munkalapot, amiből lehet körlevelet értelmesen csinálni a Wordben, vagy akár Excel munkalapon is megoldható.
Üdv.
-
-
Fferi50
Topikgazda
Szia!
Szerintem az természetes, ami történik. Egy hosszabb szövegtartalom nem fér le ugyanazon a helyen. Tehát a megnevezésedet tartalmazó szövegeket kell úgy formázni, hogy alkalmazkodjon a hozzá tartozó értékek hosszának változásához.
Például megpróbálhatnád táblázatként formázni az egész tartalmat. A táblázat első oszlopa a megnevezések, ezeket függőlegesen középre, vagy felülre,alulra állítod be. A táblázat második oszlopába kerülnek a tulajdonságokat tartalmazó mezők, amelyek elhelyezkedését szintén megadhatod. A táblázat képes automatikusan felvenni a benne levő szöveg méretét.Üdv.
PS. Csak ismétlésként, a körlevélbe egyetlen egyszer beválogatod az Excelből a szükséges mezőket. Ezek a mezők az Excel cella tartalmának változásakor megváltoznak. Nem kell semmit beilleszteni. -
Delila_1
veterán
Végre megértettem, mi a gondod. Te 1 termékhez az összes paramétert 1 mezőben akarod tárolni az Excelben, és ez a hiba.
Szedd szét a kép szerint.
Az Excelben adsz egy-egy szöveget a címsorban. Ezek lehetnek rövidek. A "rendes" címet a Wordben add meg (foly.szemb.ell az Excelben, folyással szembeni ellenállás: a Wordben).
Látod, betettem egy új oszlopot JEL címmel. Ide írsz *-ot azokhoz a tételekhez (vagy csak egyhez), ami(ke)t a Word körlevélben akarsz megjeleníteni. A kritérium ebben az esetben, hogy a JEL mező értéke *.
-
Fferi50
Topikgazda
-
Fferi50
Topikgazda
Szia!
Egyrészt a Wordben is meg lehet adni, hogy a mező hogyan jelenjen meg (kapcsolók segítségével), bár erre borzasztóan kevés helpet találtam.
Másrészt és szerintem egyszerűbb, hogy az Excelben kikapod a cellából a soremelés karaktereket, hiszen ott úgysincs rá szükséged. Ezt pedig a HELYETTE függvénnyel tudod elérni. Azaz az adott cella tartalma nem simán a keresőfüggvény eredménye lesz, hanem pl. =Helyette(Fkeres......stb.;Karakter(10);"") ami kiveszi a soremelés karaktereket.
Azért azt nézd meg lsz. hogy a sortörést milyen karakter idézi elő, nem biztos, hogy Karakter(10), más is lehet. Pl. szöveg.keres függvénnyel megnézheted, van-e Karakter(10) "betű" a szövegben.
A KÓD függvény pedig megmondja egy karakter kódját.Üdv.
-
Fferi50
Topikgazda
Szia!
"most már csak azt kell megoldanom, hogy egy dokumentumon belül 20-25 építőanyag tulajdonságot tudjak automatikusan megadni
amelyek ugyan abból az excelből jönnek, és ugyan abban a doc fájlban vannak"Ennek megoldására írtam azt, hogy az Excel második sorban egymás után sorolod fel az anyagfajtákat + a tulajdonságokat:
A-D oszlop első anyag, E-H oszlop második anyag, I-L oszlop harmadik anyag és így tovább....
A fejléc pedig természetesen az első sorban minden anyagnál különbözik - mivel az lesz a körlevél mezője.
Így a Word körlevélben egymás alá, mellé tudod "behúzni" a különböző mezőket (amelyek a különböző anyagokat tartalmazzák).
Ezt a "mezőbeültetést" megcsinálod olyan hosszan, amilyen sok anyag előfordulhat.
Persze így abban az esetben, ha egy anyag nem szerepel a "receptben", ott a mező üresen fog maradni, esetleg kihúzás stb. tehetsz a mezőjébe.Fontos, hogy az Excelben egy sorban szerepeljen a 20-25 anyagra vonatkozó adat, mert így egy rekordként tudja kezelni a Word.
A Wordbeli elhelyezést pedig szépen meg tudod kreálni szerintem.Remélem, érthető.
Üdv.
-
Fferi50
Topikgazda
Szia!
Gondolom, már elmentetted egyszer a törzsdokumentumodat, ami tartalmazza mezőket is.
Amikor a Word dokumentumot megnyitod, akkor körlevél esetén keresni fogja a hozzá tartozó Excel fájlt. Ha nem találja, neked kell hozzárendelni adatforrásként - mintha egyébként fájlt nyitnál meg.Üdv.
-
Fferi50
Topikgazda
Szia!
Először nyisd meg az Excel fájlt. Utána a Word körlevél dokumentumot és rendelt hozzá a megnyitott Excelt (ha magától nem tenné meg).
Az Excel A3 cellájába írj egy akármilyen adatot, hogy 2 rekordsorod legyen.Ezután ha a 2. sorban változtatod az adatot, menj át a Word-be. A levelezés menücsoportban változtasd meg a rekordszámot (legyen előbb 2, majd utána vissza 1), ekkor a megváltozott tartalom fog megjelenni a körleveledben.
Semmit nem kell beilleszteni, tilos! Ha mindent szabályosan csináltál a körlevélben (mezőket illesztettél be), a mezők értékei automatikusan változnak a fenti műveletre.
Üdv.
-
Pakliman
tag
A DARABTELI ebben a felállásban az első találat esetén 1-et, második találat esetén 2-t stb. ad vissza eredményként.
Feltételes formázásban is működni kellene elvileg.
Amióta rátaláltam kényszerből erre a megoldásra (nagyon sokszor kell használnom), azóta egyszerűbb (?) az életem
"majd megpróbálom végig gondolni"
Csak úgy tanul az ember...
[Ezen a képen] láthatod egy gyakorlati alkalmazását.
Az O és Q oszlopokban összesíti a dolgozók bizonyos teljesítményét, de mindenkinél csak az első előfordulásnál.Most vettem észre, hogy eredetileg nem is Neked szólt a válaszom, vagy csak a fórummotor szórakozik
-
Fferi50
Topikgazda
Szia!
Hozz létre egy olyan munkalapot (ez lehet a meglevő Excel fájlban is), amelynek az első sora a fejlécet tartalmazza.
A második sorban pedig a kiválasztás (A1 cella) és a kiválasztotthoz tartozó (függvényekkel meghatározott) adatok szerepelnek. A további sorokba ne írj adatot, illetve a további sorokba is csinálhatsz kiválasztást és hozzá a tulajdonságokat.
Ez a munkalap legyen a körlevél forrása. Így mindig csak azt az egy kiválasztott rekordot fogja a körlevél mutatni neked, illetve ha több sorod is van benne, akkor egy menetben ki tudod nyomtatni minden kiválasztott tétel adatát.Üdv.
-
Fferi50
Topikgazda
Szia!
A körlevél készítőben konkrét helyekre tudod beszúrni az Excelből a mezők adatait. Ezek a helyek nem változnak, fixen megmaradnak.
A kívánt anyagot kiválaszthatod a WORD levelezés szabályok menüpontjában, illetve végigmehetsz a rekordokon egyesével.Ha több anyagot is szeretnél egy lapra, akkor a forrás Excel táblában ezeket egy sorba kell bevinni.
Üdv.
-
-
Delila_1
veterán
A laphoz kell rendelned a makrót, aminek a módját megtalálod a téma összefoglalóban..
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$B$9" Then
Application.EnableEvents = False
Range("B" & Target + 2).Validation.Add Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:="=Jel" '*******************
Application.EnableEvents = True
End If
End SubJel-nek neveztem el a területet, ahonnan az érvényesítés az adatokat veszi. Az erre hivatkozó sor végére tettem egy halom csillagot, azt írd át a saját elnevezésedre.
amelyek ugyan abból az excelből jönnek, és ugyan abban a doc fájlban vannak"
Új hozzászólás Aktív témák
Fferi50- Sony Xperia 1 V - kizárólag igényeseknek
- Megérkezett Magyarországra a Poco F8 Pro is
- Projektor topic
- Házi barkács, gányolás, tákolás, megdöbbentő gépek!
- OLED TV topic
- Vicces képek
- Milyen TV-t vegyek?
- sziku69: Fűzzük össze a szavakat :)
- Luck Dragon: Asszociációs játék. :)
- A fociról könnyedén, egy baráti társaságban
- 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!
- Számlás!Steam,EA,Epic és egyébb játékok Pc-re vagy XBox!
- Kaspersky, BitDefender, Avast és egyéb vírusírtó licencek a legolcsóbban, egyenesen a gyártóktól!
- Stalker Clear Sky Limited Collector's Edition
- PC Game Pass előfizetés
- AKCIÓ! ASUS ROG G16 (2025) G615LR 16 - Ultra 9 275HX 32GB DDR5 1TB SSD RTX 5070Ti 12GB WIN11
- BESZÁMÍTÁS! Asus H370-A i5 9600K 16GB DDR4 512GB SSD RTX 2060 Super 8GB Zalman T7 Zalman 500W
- Bomba ár! Dell Latitude 7330 - i5-1235U I 16GB I 256SSD I HDMI I 13,3" FHD I Cam I W11 I Garancia!
- Apple iPhone 13 mini Red Kompakt méret, nagy teljesítmény 256 GB Használt,szép állapot, 100%
- Telefon felvásárlás!! iPhone 16/iPhone 16 Plus/iPhone 16 Pro/iPhone 16 Pro Max
Állásajánlatok
Cég: ATW Internet Kft.
Város: Budapest
Cég: Laptopműhely Bt.
Város: Budapest