- Milyen routert?
- DIGI internet
- Kodi és kiegészítői magyar nyelvű online tartalmakhoz (Linux, Windows)
- Sweet.tv - internetes TV
- Mesterséges intelligencia topik
- Egyre több európai használja a Telegramot, ezért megkereste az EU
- Hamarosan elképesztő mennyiségű áramot fogyasztanak el az adatközpontok és az AI
- Biztonsági tanácsot és újabb áttörést ígér az OpenAI
- Vodafone otthoni szolgáltatások (TV, internet, telefon)
- Telekom otthoni szolgáltatások (TV, internet, telefon)
-
IT café
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
-
TheSaint
aktív tag
Sziasztok!
Ha valakinek lenne erre megoldása:
=(SZUMHA('W:\Árucikkek\[37526.xlsx]Szerkezeti darabjegyzék (1)'!$C$11:$C$1500;"A 102";'W:\Árucikkek\[37526.xlsx]Szerkezeti darabjegyzék (1)'!$L$11:$L$1500))*G989A külső hivatkozott fájl nevét szeretném változóban használni, az ötjegyű szám már adott a táblázat azonos sorában. Lehetséges?
Illetve arra megoldás, hogy ne kelljen megnyitni a fájlt, hanem nyitás nélkül kiolvassa az adatokat? (Jó, ez tudom meredek...)
Előre is köszi! -
TheSaint
aktív tag
válasz scott_free #26954 üzenetére
Szervusz!
"1. egy cellában a következő érték van: "Név (1234)" - hogyan tudom ebből kiszedni csak a számot? (számként persze)"
Én erre a KUTOOLS bővítményt használom:
Text Tools - Remove Characters - Non-alpha -
TheSaint
aktív tag
Erre esetleg valaki?
[link] -
TheSaint
aktív tag
Köszi, hasonlóval próbálkoztam, de mint a példán is látható egy "/" jellel kezdődik minden érték (ami a valóságban hipertitkos vállalati kódolást takar, ami így néz ki: pl.: BZ19/0473 , stb...) tehát nem tudtam egy ilyen egyszerűbb képletre redukálni a tartalmat, amit könnyebb már kezelni.
Azért várok minden ötletet. -
TheSaint
aktív tag
Üdv!
Egy főtáblából szeretnék adott oszlopokat lekérdezni olyan módon hogy a sorok mellé szabadon lehessen megjegyzéseket irogatni és a főtábla változásakor a megjegyzés maradjon az adott sor mellett ahova eredetileg be lett írva.
Kimutatástáblával ez felejtős
Csatolt beillesztéssel előbb-utóbb elcsúsznak a sorok
Adatlekérdezéssel hiába szerkesztem meg PowerQuery-vel szépen, szúrok be üres oszlopot, frissítés után törli a beírt szövegeket...
Van erre megoldás?
Köszi! -
TheSaint
aktív tag
Sziasztok!
Worksheet Change eseménnyel kapcsolatban kérnék segítséget, nem ismerem még sajnos.
A feladat egy oszlop (K) celláinak a változása esetén küldjön emailt az adott sor C oszlopában szereplő névhez tartozó email címre. Az emailcímet a munka1 lapon lévő L név oszlop mellett lévő M oszlopban található.
Az emilküldés része már le van kezelve, csak az eseményfigyeléssel nem bírok:Sub Visszajelzes()
On Error Resume Next
'Public Sub SendEMail(
Dim MailFr As String, MailCC As String, MailTo As String, MailSubject As String, MailText As String
Dim CDOMsg As Object
Dim CDOConf As Object
Dim CDOFields As Object
Then MailFr = Munka1.Cells(i, "M")
Next i
MailTo = Munka1.Cells(2, "H")
If IsEmpty(Munka1.Cells(3, "H")) = False Then MailCC = Munka1.Cells(3, "H")
If IsEmpty(Munka1.Cells(4, "H")) = False Then MailCC = MailCC & "; " & Munka1.Cells(4, "H")
MailCC = MailCC & "; " & MailFr
MailSubject = "Visszajelzés érkezett"
If
Then
MailText = MailText & Chr(10) & _
Munka2.Cells(i, "A") & " " & Munka2.Cells(i, "B") & " " & Munka2.Cells(i, "C") & " " & Munka2.Cells(i, "D") & " " & Munka2.Cells(i, "E") & " " & Munka2.Cells(i, "F") & " " & Munka2.Cells(i, "G") & " " & Munka2.Cells(i, "H") & " " & Munka2.Cells(i, "I") & Munka2.Cells(i, "J")
Next i
End If
'On Error GoTo ERRORHANDLER
Set CDOMsg = CreateObject("CDO.Message")
Set CDOConf = CreateObject("CDO.Configuration")
CDOConf.Load -1 ' CDO Source Defaults
Set CDOFields = CDOConf.Fields
With CDOFields
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "192.168.1."
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
'Anonim
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 0
'Jelszóval:
'.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
'.Item("http://schemas.microsoft.com/cdo/configuration/Sendusername") = ""
'.Item("http://schemas.microsoft.com/cdo/configuration/SendPassword") = ""
.Update
End With
Set CDOMsg.Configuration = CDOConf
CDOMsg.Subject = MailSubject
CDOMsg.From = MailFr
CDOMsg.To = MailTo
CDOMsg.CC = MailCC
CDOMsg.TextBody = MailText
CDOMsg.Send
Set CDOMsg = Nothing
Set CDOConf = Nothing
Set CDOFields = Nothing
End Sub
-
TheSaint
aktív tag
válasz sniphoe #50296 üzenetére
Az alábbi kód segítségével leszűrhetőek azok a 4 betűs szavak, amelyek első és második karaktere is mássalhangzó:
Sub FilterWords()
Dim r As Long
Dim c As Long
Dim vowels As String
vowels = "aeiou"
c = 1 ' az oszlop száma
For r = 1 To ActiveSheet.UsedRange.Rows.Count
If InStr(vowels, LCase(Left(Cells(r, c).Value, 1))) = 0 And InStr(vowels, LCase(Mid(Cells(r, c).Value, 2, 1))) = 0 Then
Cells(r, c).Interior.Color = vbGreen
Else
Cells(r, c).Interior.Color = vbRed
End If
Next r
End Sub
Be kell állítani az oszlop számát (c), amelyet ellenőrizni szeretnél. Ha a szó első és második karaktere is mássalhangzó, akkor zöldre festi a cellát, egyébként pirosra.
Utána mehet sima színszűrő akár.[ Szerkesztve ]
-
TheSaint
aktív tag
válasz kepton #50350 üzenetére
Egy megoldás:
Először a D3 cellába a darabszám, majd a C3 cellába a cikkszám:Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$C$3" Then
Dim cikkszam As String
cikkszam = Target.Value
Dim keresettSor As Range
Set keresettSor = Me.Range("A:A").Find(cikkszam, LookIn:=xlValues)
If Not keresettSor Is Nothing Then
Dim darabszam As Integer
darabszam = Me.Range("D3").Value
Me.Cells(keresettSor.row, 2).Value = Me.Cells(keresettSor.row, 2).Value + darabszam
End If
End If
End Sub
-
TheSaint
aktív tag
-
TheSaint
aktív tag
válasz TillaT #50362 üzenetére
"Esetleg létezhet olyan metódus, amivel a háttérben, a felhasználó által érzékelhetetlen pillanatig aktívvá tehetnék egy másik munkalapot, majd egyből visszatérnék az adott munkalapra?"
Jó ötlet, erre van is megoldás elvileg:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim currentSheet As Worksheet
Set currentSheet = ActiveSheet
vbnet
Copy code
ThisWorkbook.Sheets(1).Activate
Application.OnTime Now + TimeValue("00:00:01"), _
"GoBackToCurrentSheet"
Sub GoBackToCurrentSheet()
currentSheet.Activate
Call ScrollAreaInterpret
End Sub
End Sub
-
TheSaint
aktív tag
válasz TillaT #50365 üzenetére
"Arra még nem sikerült rájönnöm, hogy a kód hatása alatt miért nem engedi a sorok és/vagy oszlopok kijelölésével az egész sorok/oszlopok beszúrását/törlését; hogy miért csak a táblázaton belüli cellák kijelölésével enged beszúrni és törölni egész sorokat/oszlopokat"
Egy próba erejéig:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Rows.Count > 1 Or Target.Columns.Count > 1 Then
Application.CutCopyMode = False
Application.OnKey "^+{INSERT}", "InsertEntireRowOrColumn"
Application.OnKey "^+{DELETE}", "DeleteEntireRowOrColumn"
Else
Application.OnKey "^+{INSERT}"
Application.OnKey "^+{DELETE}"
End If
End Sub
Sub InsertEntireRowOrColumn()
If Selection.Rows.Count > 1 Then
Selection.EntireRow.Insert
ElseIf Selection.Columns.Count > 1 Then
Selection.EntireColumn.Insert
End If
End Sub
Sub DeleteEntireRowOrColumn()
If Selection.Rows.Count > 1 Then
Selection.EntireRow.Delete
ElseIf Selection.Columns.Count > 1 Then
Selection.EntireColumn.Delete
End If
End Sub
-
TheSaint
aktív tag
-
TheSaint
aktív tag
válasz pero19910606 #50485 üzenetére
Sima szövegdaraboló varázslóval szerintem mindent szépen be tudsz állítani:
(O2019-ben az Adatok fülön a Szövegből oszlopok alatt található)[ Szerkesztve ]
-
TheSaint
aktív tag
válasz Lasersailing #50681 üzenetére
Két lépésben szerintem így jó lehet:
keresdatum_raw = Sheets("Serials").Cells(se_sm, 4).Value
keresdatum = Format(DateValue(Left(keresdatum_raw, InStr(1, keresdatum_raw, "_") - 1)), "dd/mm/yyyy") -
TheSaint
aktív tag
Remélem ez segít:
Válaszd ki az oszlopot, amely alapján szeretnéd szétbontani a táblázatot, és kattints rá jobb egérgombbal.
Válaszd ki a "Csoportosítás" opciót.
A "Csoportosítás" ablakban add meg a következőket:
Az "Új csoportosítás hozzáadása" gombra kattintva add hozzá az oszlopot, amely alapján szét szeretnéd bontani a táblázatot.
Az "Új oszlop neve" mezőben add meg az új oszlop nevét
Az "Összes sor" opciót válaszd ki a "Művelet" mezőben. Kattints a "OK" gombra.
Az eredményül kapott táblázatban kattints az "Elemek kibontása" gombra az oszlop mellett.
Az "Elemek kibontása" ablakban válaszd ki a "Új oszlopnevek" opciót, és add meg az új oszlop nevét. Kattints a "OK" gombra.
A táblázatban kattints a "Bezárás és betöltés" gombra a felső menüsorban.
Válaszd ki a "Táblázat" opciót, majd kattints a "Betöltés" gombra.
Az eredményül kapott táblázatban kattints a "Táblázatba" gombra az oszlop mellett.
Az "Táblázatba" ablakban válaszd ki az "Új munkalap" opciót, és add meg az új lap nevét, pl. "Bolt".
Kattints a "OK" gombra.
Ismételd meg a folyamatot minden egyes értékkel, hogy létrehozd az összes lapot.
A "Bezárás és betöltés" gombra kattintva mentheted az eredményt, amely az összes új lapot tartalmazza. -
TheSaint
aktív tag
Erre a porblémára lenne-e esetleg valakinek javaslat, kifogytam sajnos az ötletekből:
Egy táblázatot szűr le egy makró és a szűrt táblázatokat elküldi emailekben.
Minden szépen és flottul megy, de a szűrések után az excel megkergül, nem mükődnek gombok, görgetés szétesik, stb. Mi, hol lehet a gond?' Munkalapok beállítása
Set ws1 = ThisWorkbook.Sheets("Munka1")
Set ws3 = ThisWorkbook.Sheets("Munka3")
ws1.AutoFilterMode = False
' Szűrési tartomány beállítása a "Munka1" lapon (A-M oszlop)
Set filterRange = ws1.Range("A3:M" & ws1.Cells(ws1.Rows.Count, "K").End(xlUp).Row)
' Kiválasztott nevek definiálása
filterValues = Array("X", "Y")
' E-mail címek táblázatának inicializálása a "Munka3" lapon
Set emailTable = CreateEmailTable(ws3)
' Minden egyedi értékhez készítünk egy külön e-mailt
For Each filterValue In filterValues
' Szűrés a K oszlop alapján a "Munka1" lapon
filterRange.AutoFilter Field:=11, Criteria1:=filterValue
' Csak folytatjuk, ha vannak szűrt sorok
If Application.WorksheetFunction.Subtotal(103, filterRange.Columns(1)) > 1 Then
-
TheSaint
aktív tag
válasz Fferi50 #52503 üzenetére
Ezek stimmelnek.
Így néz ki a teljes kód, egy adatbázislekérés van a táblázatban. Még sose futottam bele ilyen megmagyarázhatatlan hibába:Private Sub Workbook_Open()
' Adatkapcsolatok frissítése
ThisWorkbook.RefreshAll
' Azonnal elindítjuk az időzítőt, amely a háttérben fut
StartTimer
End Sub
Sub StartTimer()
' Időzítő beállítása 15 másodpercre
Application.OnTime Now + TimeValue("00:00:15"), "ThisWorkbook.ProcessAfterDelay"
End Sub
Sub ProcessAfterDelay()
' Ellenőrizze, hogy a munkafüzet meg van-e nyitva
If ThisWorkbook.Name = "e.xlsm" Then
' Változók deklarálása
Dim ws1 As Worksheet ' "Munka1" lap
Dim ws3 As Worksheet ' "Munka3" lap
Dim filterRange As Range
Dim filterValues() As Variant
Dim filterValue As Variant
Dim bodyText As String
Dim emailTable As Object
Dim CDO_Mail As Object
Dim CDO_Config As Object
' CDO konfiguráció beállítása
Set CDO_Mail = CreateObject("CDO.Message")
Set CDO_Config = CreateObject("CDO.Configuration")
CDO_Config.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
CDO_Config.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "192.168.."
CDO_Config.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
CDO_Config.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
CDO_Config.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = ""
CDO_Config.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = ""
CDO_Config.Fields.Update
Set CDO_Mail.Configuration = CDO_Config
' Munkalapok beállítása
Set ws1 = ThisWorkbook.Sheets("Munka1")
Set ws3 = ThisWorkbook.Sheets("Munka3")
ws1.AutoFilterMode = False
' Szűrési tartomány beállítása a "Munka1" lapon (A-M oszlop)
Set filterRange = ws1.Range("A3:M" & ws1.Cells(ws1.Rows.Count, "K").End(xlUp).Row)
' Kiválasztott nevek definiálása
filterValues = Array("X", "Y")
' E-mail címek táblázatának inicializálása a "Munka3" lapon
Set emailTable = CreateEmailTable(ws3)
' Minden egyedi értékhez készítünk egy külön e-mailt
For Each filterValue In filterValues
' Szűrés a K oszlop alapján a "Munka1" lapon
filterRange.AutoFilter Field:=11, Criteria1:=filterValue
' Csak folytatjuk, ha vannak szűrt sorok
If Application.WorksheetFunction.Subtotal(103, filterRange.Columns(1)) > 1 Then
' E-mail tartalma összeállítása
bodyText = "" & filterValue & " m:" & vbCrLf & vbCrLf
bodyText = bodyText & "" & vbCrLf & vbCrLf
' HTML formátumban konvertált táblázat hozzáadása az üzenethez
bodyText = bodyText & RangetoHTML(filterRange.SpecialCells(xlCellTypeVisible))
' E-mail cím meghatározása a filterValue alapján a "Munka3" lapon
Dim emailCim As String
emailCim = GetEmailFromTable(emailTable, filterValue)
' Csak folytatjuk, ha sikerült e-mail címet meghatározni
If emailCim <> "" Then
' E-mail küldése CDO objektummal
With CDO_Mail
.Subject = "D"
.From = "@.hu"
.To = emailCim
.cc = "@.hu"
.HTMLBody = bodyText ' HTML formátumú tartalom hozzáadása az üzenethez
.Send
End With
End If
End If
' Szűrés törlése
ws1.AutoFilterMode = False
Next filterValue
' CDO objektumok bezárása
Set CDO_Mail = Nothing
Set CDO_Config = Nothing
' Időzítő újraindítása 1 percre
Application.OnTime Now + TimeValue("00:01:00"), "ThisWorkbook.SaveAndCloseWorkbook"
End If
End Sub
Sub SaveAndCloseWorkbook()
' Táblázat mentése és bezárása
ThisWorkbook.Save
ThisWorkbook.Close
End Sub
Function RangetoHTML(rng As Range)
' Függvény a táblázat HTML formátumban történő konvertálásához
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
' Táblázat exportálása HTML fájlba
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
' HTML fájlba mentés
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
' HTML tartalom olvasása
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
' Táblázat törlése és ideiglenes munkafüzet bezárása
TempWB.Close SaveChanges:=False
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Function CreateEmailTable(ws As Worksheet) As Object
' E-mail címek táblázatának létrehozása és feltöltése
Dim emailTable As Object
Set emailTable = CreateObject("Scripting.Dictionary")
Dim i As Long
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
For i = 1 To lastRow
Dim nev As String
Dim email As String
nev = ws.Cells(i, 2).Value
email = ws.Cells(i, 3).Value
emailTable(nev) = email
Next i
Set CreateEmailTable = emailTable
End Function
Function GetEmailFromTable(emailTable As Object, key As Variant) As String
' E-mail cím lekérdezése a táblázatból a megadott kulcs alapján
On Error Resume Next
GetEmailFromTable = emailTable(key)
On Error GoTo 0
End Function
-
TheSaint
aktív tag
válasz Fferi50 #52515 üzenetére
1. Oracle adatbázis ODBC-n keresztül, Office 2019 (32bit minden)
2. Voltak gondjaim az adatfrissítéssel, ezzel a megoldással sikerült biztosítsani, hogy frissüljenek az adatok és azokat küldje el.
3. Ebben már nem vagyok én sem biztos, de napközben dolgozom más táblázatokkal, akkor így gondoltam biztosítani, hogy a makró biztosan elinduljon
4. Mert amúgy nincs rá szükség, de hiba esetén akkor még rá tudok nézni gyorsan. Mint írtam, mellette dolgozok más táblázatokkal és azokat is tönkrevágja, lentebb a kép mi a végeredmény. Excel bezár és újranyit oldja csak meg. Windows feladatütemező nyitja meg, ha nem vagyok vagy hétvégén alvó állapotból felébreszti a gépet, elküldi amit kell és vissza alszik. Eseménykezelő nincs.
Új hozzászólás Aktív témák
Állásajánlatok
Cég: Ozeki Kft.
Város: Debrecen
Cég: Promenade Publishing House Kft.
Város: Budapest