Új hozzászólás Aktív témák

• #54440 Mutt senior tag DasBoot #54438

  Új Válasz 2025-05-29 18:35:02 #54440

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Mutt

  senior tag

  válasz DasBoot #54438 üzenetére

  Szia,

  Nem hinném hogy tud segíteni, de ez a makró megnézi a képleteket tartalmazó cellákat és próbál bennük hibát találni. Az eredményt az immediate ablakba írja ki.
  A CheckFormula függvényben 4 általános hiba ellenőrzés van:
  1) a képlet nem megfelelően kezdődik
  2) zárójelek nincsenek párban
  3) körkörös hivatkozás van a cellában
  4) a fájl hívatkozás érvénytelen

  Sub ListFormulas()
    Dim wsCurrent As Worksheet
    Dim rngFormula As Range
    
    For Each wsCurrent In ThisWorkbook.Worksheets
        With wsCurrent
            'nézzük elöször hogy van-e hibát tartalmazó cellát
            On Error Resume Next
            Set rngFormula = .Cells.SpecialCells(xlCellTypeFormulas, 16)
            On Error GoTo 0
            
            If Not rngFormula Is Nothing Then
                Call PrintFormulas(rngFormula, 100)
            End If
            
            'nézzük a nem hibát tartalamazó cellákat
            On Error Resume Next
            Set rngFormula = .Cells.SpecialCells(xlCellTypeFormulas, 7)
            On Error GoTo 0
            
            If Not rngFormula Is Nothing Then
                Call PrintFormulas(rngFormula, 100)
            End If
        End With
    Next wsCurrent
End Sub

  Sub PrintFormulas(rng As Range, counter As Long)
    Dim r As Range, c As Long
    Dim keplet As String, hiba As String
    c = 1
    For Each r In rng
        keplet = r.Formula2
        hiba = CheckFormula(keplet, r.Address)
        
        If hiba <> "" Then
            Debug.Print "Hely: " & r.Parent.Name & r.Address & ", Hiba: " & hiba & ", Képlet: " & keplet
        End If
        c = c + 1
        
        If c > counter Then Exit For
    Next r
End Sub

Function CheckFormula(str As String, loc As String) As String
    CheckFormula = ""
    'nézzük hogy mivel kezdõdik a képlet
    If InStr(1, "=+-@", Left(str, 1)) = 0 Then CheckFormula = "Elsõ karakter hibás"
    
    'képletben párosával kell lennie a zárójeleknek
    Dim leftBracket
    leftBracket = Len(str) - Len(Replace(str, "(", ""))
    If Len(str) - Len(Replace(str, ")", "")) <> leftBracket Then CheckFormula = "Zárójel nincs párban"
    
    'körkörös hivatkozás: képletben saját cella hivatkozás nem lehet
    'hivatkozás lehet: A1, $A$1 formátumban, töröljük a $ jeleket az ellenõrzéshez
    If InStr(1, Replace(str, "$", ""), Replace(loc, "$", "")) > 0 Then CheckFormula = "Körkörös hivatkozás"
    
    'keressünk fájl hivatkozást a képletben
    Dim filePath As String
    If InStr(1, str, "[") > 0 Then
        filePath = Mid(str, 2, InStr(1, str, "]") - 1)
        
        'töröljük a [ ] ' jeleket
        filePath = Replace(Replace(Replace(filePath, "[", ""), "]", ""), "'", "")
                
        'létezik a fájl?
        If Len(filePath) > 0 Then
            If (Dir(filePath) = "") Then CheckFormula = "Fájl nem létezik"
        End If
    End If
End Function

• #54430 bpmcwap senior tag Mutt #54429

  Új Válasz 2025-05-28 08:53:07 #54430

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  bpmcwap

  senior tag

  válasz Mutt #54429 üzenetére

  magát az excelt mentettem le jelszóval és találtam egy ilyen kódot, amit meg naplózáshoz fogok használni... még nem próbáltam, de elvileg ez működik - ennyire nem értek hozzá

  Private Sub Workbook_Open()
Dim logSheet As Worksheet
Dim nextRow As Long
Dim userName As String
Dim timeStamp As String
Const LOG_SHEET_NAME As String = "Napló" ' A napló munkalap neve

On Error Resume Next
Set logSheet = ThisWorkbook.Sheets(LOG_SHEET_NAME)

' Ha nincs ilyen lap, létrehozza és nagyon elrejti
If logSheet Is Nothing Then
Application.ScreenUpdating = False
Set logSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
logSheet.Name = LOG_SHEET_NAME
logSheet.Cells(1, 1).Value = "Időbélyeg"
logSheet.Cells(1, 2).Value = "Felhasználó"
logSheet.Cells(1, 3).Value = "Esemény"
logSheet.Visible = xlSheetVeryHidden ' Nagyon rejtett!
Application.ScreenUpdating = True
End If
If logSheet Is Nothing Then Exit Sub ' Hiba esetén kilép
On Error GoTo 0 ' Visszaállítjuk a normál hibafigyelést a lapkezelés után

On Error Resume Next ' Újra bekapcsoljuk az általános hibaátugrást az íráshoz

userName = Environ("USERNAME") ' Windows felhasználónév
If userName = "" Then userName = "Ismeretlen"
timeStamp = Format(Now(), "yyyy-mm-dd hh:nn:ss")

' Következő üres sor keresése (rejtett lapon is működik)
nextRow = logSheet.Cells(logSheet.Rows.Count, "A").End(xlUp).Row + 1
If nextRow < 2 Then nextRow = 2

' Adatok írása
logSheet.Cells(nextRow, 1).Value = timeStamp
logSheet.Cells(nextRow, 2).Value = userName
logSheet.Cells(nextRow, 3).Value = "Megnyitva"

' Nem mentjük automatikusan a munkafüzetet itt!
On Error GoTo 0
End Sub

• #54396 Mutt senior tag Mutt #54392

  Új Válasz 2025-05-19 17:16:22 #54396

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Mutt

  senior tag

  válasz Mutt #54392 üzenetére

  Érdekelt a ChatGPT megoldása is.

  Ezt adtam meg neki: "can you write for me a VBA code which joins texts of Excel cells while keeping their original formatting?"

  Erre azt a kódot adta vissza:
  Sub JoinCellsWithFormatting()
    Dim rng As Range
    Dim cell As Range
    Dim destCell As Range
    Dim charIndex As Long
    
    ' Ask user to select cells to join
    On Error Resume Next
    Set rng = Application.InputBox("Select the cells to join (same row or column):", Type:=8)
    On Error GoTo 0
    If rng Is Nothing Then Exit Sub
    ' Ask user to select destination cell
    On Error Resume Next
    Set destCell = Application.InputBox("Select the destination cell:", Type:=8)
    On Error GoTo 0
    If destCell Is Nothing Then Exit Sub
    ' Clear previous content
    destCell.Value = ""
    charIndex = 1
    ' Loop through selected cells
    For Each cell In rng.Cells
        If cell.Value <> "" Then
            ' Copy each character with formatting
            With cell
                Dim i As Long
                For i = 1 To Len(.Text)
                    destCell.Characters(Start:=charIndex, Length:=1).Text = Mid(.Text, i, 1)
                    With .Characters(i, 1).Font
                        With destCell.Characters(charIndex, 1).Font
                            .Name = .Name
                            .FontStyle = .FontStyle
                            .Size = .Size
                            .Bold = .Bold
                            .Italic = .Italic
                            .Underline = .Underline
                            .Color = .Color
                        End With
                    End With
                    charIndex = charIndex + 1
                Next i
            End With
            ' Add space (or separator) between cells, if needed
            destCell.Characters(Start:=charIndex, Length:=1).Text = " "
            charIndex = charIndex + 1
        End If
    Next cell
    MsgBox "Cells joined with formatting preserved.", vbInformation
End Sub

  A kód lefut, de a szöveget formázás NÉLKÜL fűzi össze.
  Elsőre nekem sem tünt fel a hiba a kódban, de aztán lépésről-lépésre nézve kijött a hiba.

  A 31-32-es sorokban WITH-eket használ, hogy rövidebben tudjun hivatkozni az objektumokra, azonban nem számol azzal, hogy amint egy új WITH indul a korábbiak elvesztik érvényességüket és onnantól TELJES NÉVVEL kell hivatkozni az előző objektumra. MS

  Vagyis a 33-as sorban a .Name = .Name helyett .Name = cell.Characters(i,1).Font.Name kell. Ezzel helyesen fut le.
  A visszajelzés után ChatGPT javította a kódot.

  Kérdés, hogy ez maradandó vagy másnak is el fogja-e követni ugyanezt a hibát?
  Alakul azért.

  üdv

• #53408 Mutt senior tag modflow #53394

  Új Válasz 2024-10-11 23:03:57 #53408

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Mutt

  senior tag

  válasz modflow #53394 üzenetére

  Szia,

  Itt egy VBA kód amivel egy "Summary" elnevezésű lapra ki tudod íratni, hogy a munkafüzet lapjain milyen képletek találhatóak. Ha lefuttatod mindkét fájlon, akkor össze tudod hasonlítani a listákat.

  Sub ListCellswithFormulas()
    Dim ws As Worksheet
    Dim rngFormulas As Range
    Dim wsReport As Worksheet
    Dim a As Long, c As Long
    Dim out As Long
    
    Set wsReport = ThisWorkbook.Worksheets("Summary")
   
    out = 2
    
    With wsReport
        .Range("A1") = "Lap"
        .Range("B1") = "Cella"
        .Range("C1") = "Képlet"
    
        For Each ws In ThisWorkbook.Worksheets
            On Error Resume Next
            Set rngFormulas = ws.Cells.SpecialCells(xlCellTypeFormulas, 23)
            On Error GoTo 0
    
            If Not rngFormulas Is Nothing Then
                For a = 1 To rngFormulas.Areas.Count
                    For c = 1 To rngFormulas.Areas(a).Count
                        .Cells(out, "A") = ws.Name
                        .Cells(out, "B") = rngFormulas.Areas(a).Item(c).Address
                        .Cells(out, "C") = "'" & rngFormulas.Areas(a).Item(c).Formula2
                        out = out + 1
                    Next c
                Next a
                
                Set rngFormulas = Nothing
            End If
        Next ws
    End With
End Sub

  üdv

• #53136 Mutt senior tag Owlet #53134

  Új Válasz 2024-09-02 21:57:25 #53136

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Mutt

  senior tag

  válasz Owlet #53134 üzenetére

  Szia,

  Neked kell sorba rendezni a dátumokat, erre van több megoldás is. A QuickSort elég gyors nagyobb adatsoron is.

  Én még annyit kavartam, hogy ha előfordulnának ismétlődő szabad dátumok, akkor azt egy collection-el előbb kiszűrtem.

  Private Sub FillDates2()
Dim ws As Worksheet
Dim cell As Range
Dim greenColor As Long
greenColor = RGB(0, 204, 102)

Set ws = ThisWorkbook.Sheets("2025")

Dim datumokColl As New Collection 'collection esetén csak egyedi értékek maradnak meg
Dim datumokArr() 'majd ebbe a tömbbe másoljuk át a kapott értékeket
Dim c As Long

On Error Resume Next 'collection leáll ha duplikáció van, így átugorjuk ezt
For Each cell In ws.UsedRange
If cell.Interior.Color = greenColor And IsDate(cell.Value) Then
datumokColl.Add cell.Value, CStr(cell.Value)
End If
Next cell
On Error GoTo 0

'ha van szabad dátum akkor lehet tovább menni
If datumokColl.Count > 0 Then

'a szabad dátumokat egy tömbbe kell másolni, létrehozzuk a megfelelõ méretû tömböt
ReDim datumokArr(1 To datumokColl.Count)

'átmásoljuk a collection tartalmát a tömbbe
For c = 1 To datumokColl.Count
datumokArr(c) = datumokColl(c)
Next c

'növekvõ sorba rendezzük a dátumokat
Call QuickSort(datumokArr, 1, datumokColl.Count)

'comboxhoz adjuk a dátumokat
For c = 1 To UBound(datumokArr)
Me.ErkezesiDatum.AddItem Format(datumokArr(c), "yyyy.mm.dd")
Me.TavozasiDatum.AddItem Format(datumokArr(c), "yyyy.mm.dd")
Next c

End If

End Sub

'https://stackoverflow.com/questions/152319/vba-array-sort-function
Public Sub QuickSort(vArray As Variant, inLow As Long, inHi As Long)
Dim pivot As Variant
Dim tmpSwap As Variant
Dim tmpLow As Long
Dim tmpHi As Long

tmpLow = inLow
tmpHi = inHi

pivot = vArray((inLow + inHi) \ 2)

While (tmpLow <= tmpHi)
While (vArray(tmpLow) < pivot And tmpLow < inHi)
tmpLow = tmpLow + 1
Wend

While (pivot < vArray(tmpHi) And tmpHi > inLow)
tmpHi = tmpHi - 1
Wend

If (tmpLow <= tmpHi) Then
tmpSwap = vArray(tmpLow)
vArray(tmpLow) = vArray(tmpHi)
vArray(tmpHi) = tmpSwap
tmpLow = tmpLow + 1
tmpHi = tmpHi - 1
End If
Wend

If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi
End Sub

  üdv

• #52744 gycs02 tag Fferi50 #52739

  Új Válasz 2024-05-30 14:26:04 #52744

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  gycs02

  tag

  válasz Fferi50 #52739 üzenetére

  Szia!
  Köszönöm a választ!
  Keresgettem az ajánlásod alapján, de sajnos nem jutottam előrébb. Nem vagyok képben a makró világában, csak amit megtalálok a neten azokat próbálom több-kevesebb sikerrel felhasználni, s minimálisan módosítgatni.
  Ez így most működik:

  Dim utvonal As String
  utvonal = "c:\Dokumentumok\01\1.xlsx"
  On Error GoTo 1
  ActiveWorkbook.FollowHyperlink utvonal, NewWindow:=True
  Exit Sub
  1: MsgBox Err.Description

  Hogy mi miért van benne nem tudom, egyedül az útvonal ami számomra mond valamit.
  Az elérési út az alkönyvtár kivételével minden esetben ua, a fájlnév sem változik. Azt szeretném elérni, hogyha az a fájl ami a makrót futtatja a 01-es mappában van, akkor az abban lévő 1.xls-t nyissa meg, ha a 02-ben van, akkor az abban lévőt stb.
  Lehet így érthetőbb is a kérdésem, ha megoldható kijavítanád ezek alapján?

  Az excel-ben az összes makró engedélyezve van, és pipálva a VBA projekt objektumok is.
  Az a tiltás feloldása rész nálam nincs vagy nem jó helyen keresem vagy le van tiltva. [kép]

  Köszi gycs!

• #52513 TheSaint aktív tag Fferi50 #52503

  Új Válasz 2024-04-23 12:34:06 #52513

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  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
  

• #52395 Delila_1 veterán andreas49 #52394

  Új Válasz 2024-04-02 11:30:02 #52395

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Delila_1

  veterán

  válasz andreas49 #52394 üzenetére

  Megnyitod az első nagy fájlt. Felveszel egy változót a füzet nevével.
  Rendezed a tartományt az évszám szerint. Evszam változót veszel fel. Az első évszám az oszlopban.
  Kijelölöd a másolandó tartományt – első sor=Match(Evszam, columns(1),0) , utolsó sor= Match(Evszam, columns(1),1).
  Innen lesz az ismétlés
  Megnyitod a füzetet, ahova másolni akarod külön lapokra az évszám szerinti adatokat. Ellenőrzöd, hogy van-e már Evszam nevű lap.
  Dim WS As Workbook, Evszam As String
  Evszam = "2024" ’az oszlopban lévő első évszám
  On Error Resume Next
  Set WS = Sheets(Evszam)
  If Err.Number = 9 Then
  Sheets.Add.Name = Evszam
  Else
  Sheets(Evszam).Select
  End If
  On Error GoTo 0
  Kikeresed az első üres sort, beilleszted a tartományt.
  Eddig
  Vissza az első nagy fájlba, megadod a következő évszámot – ennek a sora=range(„A” & Match(Evszam, columns(1),1)+1. Ezt az értéket adod meg új évszámként.

  Vajh' mennyire követhető ez?

• #52286 föccer nagyúr föccer #52285

  Új Válasz 2024-03-07 12:17:45 #52286

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  föccer

  nagyúr

  válasz föccer #52285 üzenetére

  Private Sub Workbook_Open()
Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim i As Integer
Dim Fileok_szama As Integer
Dim Fnev As String
Dim Kell_e_menteni As Boolean
Dim SFnev As String
i = 0
Filok_szama = 0
Fnev = ""
Kell_e_menteni = True
SFnev = ""
Sheets("Save_log").Range("T:U").ClearContents
Set oFSO = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
  If Sheets("Save_log").Range("B7").Value <> "" Then
    Set oFolder = oFSO.GetFolder(Sheets("Save_log").Range("B7").Value)
  Else
    Set oFolder = oFSO.GetFolder(Sheets("Save_log").Range("B8").Value)
  End If
If Err = 0 Then
 
For Each oFile In oFolder.Files
    If oFile.Name = Sheets("Save_log").Range("B5").Value Then
      Kell_e_menteni = False
    End If
    Sheets("Save_log").Cells(i + 1, 20) = oFile.Name
    Sheets("Save_log").Cells(i + 1, 21).Formula = "=IFERROR(MATCH(T" & i + 1 & ",M:M,0),0)"
    i = i + 1
Next oFile
Filok_szama = i
For i = 1 To Filok_szama
  If Sheets("Save_log").Cells(i, 21).Value = 0 Then
    Fnev = oFolder & "\" & Sheets("Save_log").Cells(i, 20).Value
    Kill Fnev
  End If
Next
If Kell_e_menteni = True Then
  
  SFnev = Sheets("Save_log").Range("B7").Value & Sheets("Save_log").Range("B5").Value
  ActiveWorkbook.SaveAs Filename:=SFnev
End If
Else
  If Sheets("Save_log").Range("B7").Value <> "" Then
    MkDir Sheets("Save_log").Range("B7").Value
  Else
    MsgBox "Nem találom a biztonsági mentés helyét. Kérlek add meg a biztonsági mentés helyét."
    Call XBUP_mentesi_hely_Valasztas
    MkDir Sheets("Save_log").Range("B7").Value
  End If
End If
On Error GoTo 0
End Sub

• #51271 13128814 tag Fferi50 #51270

  Új Válasz 2023-08-05 14:51:58 #51271

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  13128814

  tag

  válasz Fferi50 #51270 üzenetére

  Utána az AI:AR utolsó sora ami szintén sum függvényekből áll bemásolódik a következő helyre:
  
  [link] (utolsó sor)
  [link] (ide másolódik)

  Ami izgi, az az, hogy utána generálódik még egy pivot, viszont ott már azokat a kártyákat vizsgáljuk ahol a változás "1":

  [link]

  Biztos van szofisztikáltabb megoldás ezekre, én is csak örököltem ezt a feladatot, csak mivel simán elmegy 1 - 1,5 óra rá hetente, gondoltam megpróbálom lemakrózni. Az más kérdés hogy már annyi munkaórám van benne, mintha fél évig manuálisan töltögettem volna. De ez a "tudás" már az enyém!

  Végül is úgy oldottam meg, hogy bekapcsoltam a szűrőket, és utána húztam végig a képleteket:
  
  With PSheet.PivotTables("PIVOT").PivotFields("változás")
            .Orientation = xlPageField
            .Position = 2
            .PivotItems("0").Visible = True
            On Error Resume Next
            .PivotItems("(blank)").Visible = False
            .PivotItems("1").Visible = False
            On Error GoTo 0
        End With
        
        With PSheet.PivotTables("PIVOT").PivotFields("Elérhető")
            .Orientation = xlPageField
            .Position = 3
            .PivotItems("1").Visible = True
            .PivotItems("2").Visible = True
            ' Hide other items if present
            On Error Resume Next
            .PivotItems("(blank)").Visible = False
            .PivotItems("0").Visible = False
            On Error GoTo 0
        End With
  
  Bár ettől függetlenül nagyon zavar hogy ilyen lett, mert így nem tetszik. Kicsit tróger megoldásnak érzem.

• #51265 13128814 tag

  Új Válasz 2023-08-04 15:31:14 #51265

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  13128814

  tag

  Sziasztok!

  Egy pivot generálásnál akadtam el és a ChatGPT sem barátom már ebben.

  A jelenség az, hogy ha a generált pivotban szűrök, akkor a mellette lévő sorok nem követik le a szűrést hanem fixen ott maradnak (mármint a pivot tartomány melletti sorok). Ezzel az a baj, hogy az AH-nak egyenlőnek kell lennie az A oszlopban lévő adatokkal (ebben a formában: A6 = AH6), mert utána sok képletem van. Csak mivel a pivotban alkotott szűrés nincs kihatással az AH-tól kezdődő oszlopokra, így a képletek fals számokat kalkulálnak. Hogyan tudnám függővé tenni a többi oszlop sorát is a pivot szűrésétől?

  Itt generálom le a pivotot:

  Sub pivot(ByRef ujWb As Workbook)
    Dim PTable As pivotTable
    Dim PCache As PivotCache
    Dim PRange As Range
    Dim PSheet As Worksheet
    Dim DSheet As Worksheet
    Dim LR As Long
    
    Set PSheet = ujWb.Worksheets(1)
    Set DSheet = ujWb.Worksheets(2)
    
    LR = DSheet.Cells(Rows.Count, 1).End(xlUp).Row
    
    Set PRange = DSheet.Range("A2:S" & LR)
    Set PCache = ujWb.PivotCaches.Create _
        (xlDatabase, SourceData:=PRange)
        
    On Error Resume Next
    Set PTable = PCache.CreatePivotTable(TableDestination:=PSheet.Cells(1, 1), TableName:="PIVOT")
    On Error GoTo 0
    If PTable Is Nothing Then
        MsgBox "Nem sikerült létrehozni a pivot táblát. Ellenőrizd a célcellát és az adatokat.", vbExclamation
    Else
        ' Pivot tábla létrehozva sikeresen, folytasd a kód futtatását
        
        With PSheet.PivotTables("PIVOT").PivotFields("Design_no")
            .Orientation = xlRowField
            .Position = 1
        End With
    
        With PSheet.PivotTables("PIVOT").PivotFields("Code")
            .Orientation = xlColumnField
            .Position = 1
        End With
        
        With PSheet.PivotTables("PIVOT").PivotFields("Kártya gyári szám")
            .Orientation = xlDataField
            .Position = 1
        End With
        
        With PSheet.PivotTables("PIVOT").PivotFields("CH")
            .Orientation = xlPageField
            .Position = 1
        End With
        
        With PSheet.PivotTables("PIVOT").PivotFields("változás")
            .Orientation = xlPageField
            .Position = 2
        End With
        
        With PSheet.PivotTables("PIVOT").PivotFields("Elérhető")
            .Orientation = xlPageField
            .Position = 3
        End With
    End If
End Sub

  Itt töltöm ki az AH-t:

  Sub pivotAtalakitas(ByRef ujWb As Workbook)
    
    Dim LR As Long
    Dim ws As Worksheet
    Dim LastRowCell As Range
    Set ws = ujWb.Worksheets("PIVOT")
    Set LastRowCell = ws.Columns("A").Find(What:="*", After:=ws.Cells(1, "A"), LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
    
    If Not LastRowCell Is Nothing Then
        LR = LastRowCell.Row
        Debug.Print LR
        Dim i As Long
        For i = 6 To LR
            ws.Cells(i, "AH").Value = ws.Cells(i, "A")
        Next i
    Else
        Debug.Print "A oszlop üres"
    End If
    
    ThisWorkbook.Worksheets("Fejléc").Range("A4:J5").Copy
    ujWb.Worksheets(1).Range("AI4").PasteSpecial
    Application.CutCopyMode = False
    
End Sub

• #51019 Fferi50 Topikgazda föccer #51018

  Új Válasz 2023-05-22 09:52:35 #51019

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Fferi50

  Topikgazda

  válasz föccer #51018 üzenetére

  Szia!
  A fileokat begyűjtő ciklus elé:
  On Error Resume Next
A Workbooks.Open utasítás után:
If Err=0 Then
   ' Ide jönnek a sikeres megnyitás utáni műveletek
a fájlbegyűjtő ciklus Next utasítása elé (ami most az utolsó sor)
Else
  ' Ide jön a hibakezelő 2 sorod +
    Err=0
End If
  A folyamat (makró) legvégén pedig On Error Goto 0 - a hibakezelés visszaadása a VBA-nak.
  Üdv.

• #50798 Mutt senior tag andreas49 #50785

  Új Válasz 2023-04-08 18:42:56 #50798

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Mutt

  senior tag

  válasz andreas49 #50785 üzenetére

  Szia,

  Nézd meg ezt az UDF-et.
  Használata: =Hasonlo(<cella amihez hasonlót keresünk>;<tartomány a hasonló szövegekkel>;<max eltérések száma>;<kis és nagybetű eltérjen>)

  Function Hasonlok(mit As Range, hol As Range, Optional max_elteres As Long = 2, Optional kisnagybetuazonos As Boolean = False) As Variant
Dim dictMit As Object
Dim dictHol As Object
Dim adat As Range
Dim c As Long, elteres As Long
Dim key As String, val As Long
Dim collEredmeny As New Collection
Dim arrEredmeny()

'late biding-gal létrehozunk két szótárt, ahol {betű:darabszám} párosokat tudunk képezni
Set dictMit = CreateObject("Scripting.Dictionary")
Set dictHol = CreateObject("Scripting.Dictionary")

'on error a collection miatt kell, mert kiakad ha egy már létező elemet akarunk újra felvenni
On Error Resume Next

'végigmegyünk a megadott tartomány elemein
For Each adat In hol
'átugorjuk ha véletlenül a tartomány rész az eredeti szöveg amihez hasonlókat keresünk
If adat.Address <> mit.Address Then
'az eredeti szöveget és hasonlóság miatt vizsgáltat felbonyjuk {betű:darabszám} párosokra
Call felbont(Trim(adat.Text), dictHol, kisnagybetuazonos)
Call felbont(Trim(mit.Text), dictMit, kisnagybetuazonos)

'megnézzük, hogy a két szövegben mely betük egyeznek és a darabszámukat csökkentjük a
'másik szövegben található darabszámmal
For c = 0 To dictMit.Count - 1
key = dictMit.Keys()(c)

If dictHol.exists(key) Then
val = dictHol(key)

If val >= dictMit(key) Then
dictHol(key) = val - dictMit(key)
dictMit(key) = 0
Else
dictMit(key) = dictMit(key) - val
dictHol(key) = 0
End If
End If
Next c

'eltéresek megszámolása
elteres = szamol(dictMit) + szamol(dictHol)

'ha a limit alatt vagyunk eltérésekben akkor elrakjuk a szöveget
If elteres <= max_elteres Then collEredmeny.Add adat.Text
End If
Next adat
On Error GoTo 0

'tömbként visszaadjuk a talált elemeket ha vannak, különben üres szöveget adunk
If collEredmeny.Count > 0 Then
ReDim arrEredmeny(1 To collEredmeny.Count)
For c = 1 To collEredmeny.Count
arrEredmeny(c) = collEredmeny.Item(c)
Next c
Hasonlok = arrEredmeny
Else
Hasonlok = ""
End If


End Function

Private Function felbont(s As String, o As Object, m As Boolean)
Dim c As String
Dim x As Long

'töröljük az eddigi tartalmat
o.RemoveAll

'ha szükséges akkor mindent nagybetűsre alakítunk
If m Then s = UCase(s)

'felszabdaljuk a szöveget {betu:darabszám} párosokra
While Len(s) > 0
c = Left(s, 1)
x = Len(s) - Len(Replace(s, c, ""))

o.Add c, x
s = Replace(s, c, "")
Wend

End Function

Private Function szamol(o As Object) As Long
Dim x As Long

'megszámoljuk hány esetben fordul elő NEM nullaszor egy betű
'ezek azok amelyek a másik szövegben nem voltak megtalálhatók
szamol = 0
For x = 0 To o.Count - 1
If o.Items()(x) > 0 Then szamol = szamol + 1
Next x

End Function

  üdv

• #50629 Delila_1 veterán Silious #50625

  Új Válasz 2023-03-02 21:09:30 #50629

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Delila_1

  veterán

  válasz Silious #50625 üzenetére

  Indítás előtt érdemes kitörölni az eddig bevitt képeket: Ctrl + g-re előjön az Ugrás menü, Irányított, Objektumok. Ez kijelöli az összes képet, Delete.
  Modulba tedd az alábbi makrót, ami az összes, A oszlopban szereplő képnév mellé beteszi a képet a C oszlopba..

  Sub Kepbeszuras()
Dim utvonal As String, kep As String, sor As Long, usor As Long

usor = Range("A" & Rows.Count).End(xlUp).Row
utvonal = "D:\Jpg\" ' itt add meg a saját útvonaladat

For sor = 1 To usor
kep = utvonal & Cells(sor, 1) & ".jpg"
Cells(sor, 3).Select
On Error Resume Next
ActiveSheet.Pictures.Insert(kep).Select
Selection.Left = Cells(sor, 3).Left + 5
Selection.Top = Cells(sor, 3).Top + 5
Selection.Width = 40 'a kép szélessége
Selection.Height = 30 'a kép magassága
On Error GoTo 0
Next
End Sub

• #50614 Delila_1 veterán Silious #50610

  Új Válasz 2023-03-02 07:04:23 #50614

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Delila_1

  veterán

  válasz Silious #50610 üzenetére

  A makrót a lapodhoz rendeld a Téma összefoglaló szerint.
  Mikor beírsz az A oszlopba egy nevet, a megadott utvonal mappából betölti a kep nevű képet a C oszlop azonos sorába.
  A makró megjegyzései sorában módosíthatsz az útvonalon, kiterjesztésen, és a képek méretein.

  Private Sub Worksheet_Change(ByVal Target As Range)
Dim utvonal As String, kep As String
If Target.Column = 1 Then
utvonal = "D:\Jpg\" ' itt add meg a saját útvonaladat
kep = utvonal & Target.Value & ".jpg" 'ha nem jpg a kiterjesztés, írd át
Range(Target.Address).Offset(0, 2).Select
On Error Resume Next
ActiveSheet.Pictures.Insert(kep).Select
Selection.Left = Target.Value.Offset(0, 2).Left + 5
Selection.Top = Target.Value.Offset(0, 2).Top + 5
Selection.Width = 40 'a kép szélessége
Selection.Height = 30 'a kép magassága
Range(Target.Address).Select
On Error GoTo 0
End If
End Sub

• #50295 TheSaint aktív tag

  Új Válasz 2023-01-22 07:37:34 #50295

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  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

• #50171 Delila_1 veterán Pá #50168

  Új Válasz 2023-01-02 20:27:19 #50171

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Delila_1

  veterán

  válasz Pá #50168 üzenetére

  A lenti 3 makrót másold be egy modulba. Az elsőt indítod, az meghívja a másik kettőt.
  Törli a Store lapot, majd feldob egy fájlválasztó ablakot.
  Indítás előtt a harmadik makróban a Munka2 nevet írd át az Update füzeted másolandó lapja nevére.
  Nem kell képletekkel "beszívni" az adatokat, mert az Update füzetből a teljes lapot másoljuk az Original-ba, majd az esetleges képletek helyére értékeket illesztünk be. Ez így gyorsabb, de az összevont cellák miatt mindenféle hiba állna elő nélküle.

  Option Explicit
Public WB

Sub Store_lap_torlese()
Dim FN
Application.DisplayAlerts = False
On Error Resume Next
Set FN = Sheets("Store")
If Err.Number = 0 Then Sheets("Store").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Fajl_Valasztas
End Sub

Sub Fajl_Valasztas()
Dim b As Integer
Set WB = Application.FileDialog(3)
With WB
.AllowMultiSelect = False
.Show
If .SelectedItems.Count = 0 Then
MsgBox "Nem választottál fájlt, befejezzük.", vbInformation, "Értesítés"
Exit Sub
Else
WB = .SelectedItems(1)
End If
End With
For b = Len(WB) To 1 Step -1
If Mid(WB, b, 1) = "\" Then
WB = Mid(WB, b + 1, 50)
Exit For
End If
Next
Sheets("Name").Cells(1) = WB
Workbooks.Open WB
Lapmasolas WB
End Sub

Sub Lapmasolas(WB)
Sheets("Munka2").Copy After:=Workbooks("Original.xlsm").Sheets(2)
Sheets("Munka2").Name = "Store"
Columns("A:Z").Copy
Range("A1").PasteSpecial xlPasteValues
Application.DisplayAlerts = False
Workbooks(WB).Close False
Application.DisplayAlerts = True
Sheets("Store").Cells(1).Select
End Sub

• #50016 Fferi50 Topikgazda Fferi50 #50015

  Új Válasz 2022-11-24 07:48:29 #50016

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Fferi50

  Topikgazda

  válasz Fferi50 #50015 üzenetére

  No itt a makró javított kiadása:
  Sub akarmi()
Dim answer As Integer, wsFound As Boolean
Dim wbSearch As Workbook, wsSearch As Worksheet
wsfound = False
On Error Resume Next
Set wsSearch = Sheets(Textbox11.Value)
If Err = 0 Then
'ha van már ilyen munkalap, akkor feltesszük a kérdést
answer = MsgBox("Ilyen nevű munkatárs már rögzítve! Biztos, hogy folytatod a rögzítést?", vbQuestion + vbYesNo + vbDefaultButton2, "Munkatárs rögzítése")
If answer = vbYes Then wsSearch.Copy after:=Sheets("Havi_TEMPLATE"): wsFound = True
Else
Err = 0
Sheets("Szemely_TEMPLATE").Copy after:=Sheets("Havi_TEMPLATE")
ActiveSheet.Name = Textbox11.Value
wsFound=True
End If
On Error GoTo 0
If wsFound Then
With ActiveSheet
.Range("A2") = Textbox11.Value & " " & ComboBox7.Value
.Range("B2") = TextBox12.Value
.Range("C2") = TextBox13.Value
.Range("D2") = TextBox14.Value
End With
MsgBox "Munkatárs sikeresen rögzitve! Kérlek zárd be és nyisd meg újra a programot!"
End If
Textbox11.Value = ""
ComboBox7.Value = ""
TextBox12.Value = ""
TextBox13.Value = ""
TextBox14.Value = ""
'Sheets(xx).Activate az alapmunkalap aktíválása, ha szükséges.
End Sub

• #50015 Fferi50 Topikgazda istvankeresz #50013

  Új Válasz 2022-11-24 07:24:15 #50015

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Fferi50

  Topikgazda

  válasz istvankeresz #50013 üzenetére

  Szia!
  Inkább ezt próbáld ki, mert a másik nem igazán jó:
  Sub akarmi()
Dim answer As Integer, wsFound As Boolean
Dim wbSearch As Workbook, wsSearch As Worksheet
wsfound = True
On Error Resume Next
Set wsSearch = Sheets(Textbox11.Value)
If Err = 0 Then
'ha van már ilyen munkalap, akkor feltesszük a kérdést
answer = MsgBox("Ilyen nevű munkatárs már rögzítve! Biztos, hogy folytatod a rögzítést?", vbQuestion + vbYesNo + vbDefaultButton2, "Munkatárs rögzítése")
If answer = vbYes Then wsSearch.Copy after:=Sheets("Havi_TEMPLATE"): wsFound = True
Else
Err = 0
Sheets("Szemely_TEMPLATE").Copy after:=Sheets("Havi_TEMPLATE")
ActiveSheet.Name = Textbox11.Value
End If
On Error GoTo 0
If wsFound Then
With ActiveSheet
.Range("A2") = Textbox11.Value & " " & ComboBox7.Value
.Range("B2") = TextBox12.Value
.Range("C2") = TextBox13.Value
.Range("D2") = TextBox14.Value
End With
MsgBox "Munkatárs sikeresen rögzitve! Kérlek zárd be és nyisd meg újra a programot!"
End If
Textbox11.Value = ""
ComboBox7.Value = ""
TextBox12.Value = ""
TextBox13.Value = ""
TextBox14.Value = ""
'Sheets(xx).Activate az alapmunkalap aktíválása, ha szükséges.
End Sub
  Egy kis magyarázat hozzá:
  Nem kell végigpörgetni a munkalapokat, mivel a vba hibakezeléssel megállapítható, ha van már ilyen munkalap => a Set után ha nincs hiba, akkor van már. Amennyiben ugyanolyan nevű új személy van, akkor ezt a munkalapot másoljuk, aminek az lesz az eredménye, hogy az Excel automatikusan ad egy sorszámot a névhez! ezzel nekünk nem kell foglalkozni.
  Ha nincs, akkor másoljuk a Templatet.
  Mivel a másolt munkalap lesz az aktív, utána beírhatjuk a szükséges adatokat az új munkalapra.
  Remélem sikerülni fog.
  Üdv.

• #50008 istvankeresz aktív tag Fferi50 #50007

  Új Válasz 2022-11-23 15:21:04 #50008

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  istvankeresz

  aktív tag

  válasz Fferi50 #50007 üzenetére

  Szia!

  Azért, mert a bezárás nélkül nem látszik az új berögzített személy, azaz a új worksheet egy másik comboboxban, ahol ezt az új worksheet-t ki lehet választani. Ezt még nem sikerült megoldanom. De rajta vagyok ezen is.

  Esetleg valami GoTo megoldás nem lehet jó nekem? Talán ha az egyik feltétel teljesül, akkor ugorjon ide, ha a másik, akkor ugorjon oda.

• #49888 the radish senior tag lappy #49884

  Új Válasz 2022-11-09 14:52:13 #49888

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  the radish

  senior tag

  válasz lappy #49884 üzenetére

  Köszönöm!

  +1:
  Adott egy zip fájlt kitömörítő makró:
  Sub Unzip()
Dim FSO As Object
Dim oApp As Object
Dim Fname As Variant
Dim FileNameFolder As Variant
Dim DefPath As String

Fname = Application.GetOpenFilename(Filefilter:="Zip Files (*.zip), *.zip", _
MultiSelect:=False)
If Fname = False Then
'Do nothing
Else
'Destination folder
DefPath = "D:\Data\" '<<< Change path
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If

FileNameFolder = DefPath

' 'Delete all the files in the folder DefPath first if you want
' On Error Resume Next
' Kill DefPath & "*.*"
' On Error GoTo 0

'Extract the files into the Destination folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items

MsgBox "You find the files here: " & FileNameFolder

On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
End If
End Sub

  Szeretném a "GetOpenFilename" opciójaként megadni, hogy pl. a fájl tallózása során a "munka" elnevézű fájlokra is szűrjön, de eddig csak a fájl típus szűrést találtam.

  Egy másik formációval ez sikerült, ott meg a kitömörítéssel nem jutok dülőre:
  Sub OpenFileFromDefaultPath()
Dim fileDialogBox As Office.FileDialog
Dim fileName As String

Set fileDialogBox = Application.FileDialog(msoFileDialogFilePicker)

With fileDialogBox
.InitialFileName = "D:\Data\"
.InitialFileName = "*munka*"

If .Show = True Then
' e nélkül is működik
fileName = .SelectedItems(1)
End If
End With
End Sub

• #48468 eszgé100 őstag

  Új Válasz 2022-02-12 08:25:04 #48468

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  eszgé100

  őstag

  Sziasztok!

  Az alabbi funkcioval megvizsgalom, hogy egy adott fajl meg van-e mar nyitva a ciklus egy korabbi lepesebeol, ha nincs, akkor a kovetkezo lepes a ciklusban megnyitja a hatterben elokeszitve a kod tovabbi lepeseihez.

  Remekul mukodik, de sajnos halozaton megosztottak a munkafuzetek igy elofordul, hogy mas is eppen hasznalja valamelyiket. Ebben az esetben ugyanugy 70-es hibakodot kapok, ami szerint meg van nyitva, de nem tudok innentol kulonbseget tenni, hogy az a sajat gepemen van-e megnyitva, vagy valaki masen. Olyan feltetelt szeretnek megvizsgalni, hogyha mas felhasznalonal van megnyitva, akkor nalam automatikusan nyiljon meg Read-Only modban, ugyanugy hatterben.

  Function IsFileOpen(sPath As String)

Dim fileNum As Integer
Dim errNum As Integer

'Allow all errors to happen
On Error Resume Next
fileNum = FreeFile()

'Try to open and close the file for input.
'Errors mean the file is already open
Open sPath For Input Lock Read As #fileNum
Close fileNum

'Get the error number
errNum = Err

'Do not allow errors to happen
On Error GoTo 0

'Check the Error Number
Select Case errNum

'errNum = 0 means no errors, therefore file closed
Case 0
IsFileOpen = False

'errNum = 70 means the file is already open
Case 70
IsFileOpen = True

'Something else went wrong
Case Else
IsFileOpen = errNum

End Select

End Function

  A kodreszlet, ami a megnyitast vegzi:

  Application.ScreenUpdating = True
ma.Visible = True

fileName = Right(sPath, Len(sPath) - InStrRev(sPath, "\"))
Application.StatusBar = "Processing File: " & fileName
Application.ScreenUpdating = False

If IsFileOpen(sPath) = False Then Workbooks.Open sPath
Windows(fileName).Visible = False

• #48139 sztanozs veterán dreizwanzig #48138

  Új Válasz 2021-12-30 16:43:58 #48139

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  sztanozs

  veterán

  válasz dreizwanzig #48138 üzenetére

  1) Filter
  2) Cellák kijelölése
  3) Find & Search > GoTo Special...
  4) Visible cells only
  5) Conditional formatting ...

• #47919 Delila_1 veterán Fferi50 #47918

  Új Válasz 2021-12-01 14:49:03 #47919

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Delila_1

  veterán

  válasz Fferi50 #47918 üzenetére

  Ez csak azt mutatja, hogy tabulálással jól lehet láttatni az összetartozó egységeket. Hibakezeléssel:

  If Range("A1") > 0 Then
Go To Hiba
Else
Range("B1") = 20: Exit Sub
End If

  Hiba:
MsgBox "..."
On Error GoTo 0

  Egy rossz példa találomra erről a fórumról:
Select Case CStr(freq)
                Case "4 weekly", "monthly"
                     nyomtatni = True
                 Case "2 monthly"
                 nyomtatni = Month(nextmonth) Mod 2 = 1
                 Case "3 monthly"
                 nyomtatni = Month(nextmonth) Mod 3 = 1
            End Select

• #47916 Fferi50 Topikgazda eszgé100 #47915

  Új Válasz 2021-12-01 12:51:21 #47916

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Fferi50

  Topikgazda

  válasz eszgé100 #47915 üzenetére

  Szia!
  1.)"a ciklus későbbi lépéseiben még szükség lesz rájuk, pl amikor egy workbookban van 20 worksheet, de nem egyszerre ömlesztve akarom őket kinyomtatni,"
  ugyanakkor a ciklusban minden sornál ott van a Workbooks.Open, anélkül, hogy megnéznéd, nincs-e már megnyitva az adott file.
  "mert utána akkor még kézzel is le kell válogatnom később"
  másrészt, ha egy következő file másik munkalapját nyomtatod utána, akkor nem kell kézzel leválogatni az előzőtől?
  2.a) szerintem alapvetően akkor van szükség GoTo utasításra, ha a makró/folyamat rosszul van megtervezve, megszervezve. Az ugrálás rontja az áttekinthetőséget és szerintem lassítja is a végrehajtást. Egy esetben látom indokoltnak, a futási hibák kezelésénél, ott ahol a hiba természete miatt külön hibakezelési rutinra van szükség az adott makrón belül. (Lásd: On Error Goto .. utasítás ).
  2.b) Mod funkció -> egy osztás maradék eredményét adja vissza. Nálad azért 1 a feltétel értéke, mert mindig az adott ciklus utáni első hónapban nyomtatod a munkafüzetet (vagy ha úgy jobban tetszik, a ciklus első hónapjában). 3 havonta esetén az 1,4,7,10 hónapban. De mondhatnád azt is, hogy a 3,6,9,12 hónapban akarod nyomtatni, akkor a 0 maradék lenne a feltétel. Tehát te döntöd el, melyik hónapban kezdődjön a nyomtatási ciklus és a maradékot annak megfelelően használod feltételnek. Ugyanez igaz a többi ciklikus feltételre is.
  3.a) Hibakezelésen tehát a felhasználói hibák vizsgálatát érted (amivel egyrészt megelőzheted fals adatok dokumentálását, másrészt program futási hibák keletkezését). Azt gondolom, erre az esetre érdemes egy külön függvényt írni, ami megizsgálja a kritikus összefüggéseket és logikai értéket ad vissza a vizsgálat eredményéről, amitől függően megy tovább a ciklus vagy elengedi azt a munkafüzetet/lapot.
  Érdemes ettől függően azon is gondolkodni, hogyan kezeljük a futás idejű hibákat, mivel nem szeretnénk, ha ezek miatt utólag kellene a felhasználókkal hibát javíttatni.
  3.b) Szűrés esetén a Darabteli függvény nincs tekintettel a szűrt állapotra valóban. Ebben az esetben a Save&close cella tartalma helyett meg kell nézned a szűrt területet makróval.
  A D oszlop szűrt tartományát a következőképpen kapod meg:
  ActiveSheet.UsedRange.Columns("D").SpecialCells (xlCellTypeVisible)
  A Find metódussal meghatározhatod a keresett érték helyét.
  Dim scrange As Range
  Majd a nyomtatás után:
  Set scrange=ActiveSheet.UsedRange.Columns("D").SpecialCells (xlCellTypeVisible).Find(what:=sPath,after:=Range("D" & counter))
If scrange.Row<=counter then --- save & close
  Mivel nincs további találalat a szűrt tartományban, ezért az első találatra fog visszaugrani.
  Üdv.

• #47915 eszgé100 őstag Fferi50 #47894

  Új Válasz 2021-12-01 10:44:47 #47915

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  eszgé100

  őstag

  válasz Fferi50 #47894 üzenetére

  1.) pontosan,  ott nem kell bezárni a fájlt, mert még a ciklus későbbi lépéseiben még szükség lesz rájuk, pl amikor egy workbookban van 20 worksheet,  de nem egyszerre ömlesztve akarom őket kinyomtatni, mert utána akkor még kézzel is le kell válogatnom később, amit nem szeretnék. A Save&Close oszlop celláinak értéke az =IF(COUNTIF(D2:INDIRECT("D" & COUNTIF(D,"<>")),D2)>1,"no","yes") függvénnyel van meghatározva, ami eddigi tesztjeim alapján dinamikusan változik, amikor ugyanaz az elérési útvonal kerül a Path oszlop celláiba. Amennyiben az adott elérési útvonal nem ismétlődik többet a maradék cellatartományban az érték Save&Close "yes"-re változik és a workbook ment és bezárul

  2a.) mi pontosan a hátránya, hogyha GoTo-val ugrálok? 
  2b.) Másik ezzel kapcsolatban, hogy a Mod funkció működését nem teljesen értem, legalábbis az én esetemben. Pl ha "6 monthly"-t keresem, akkor azokat a hónapokat keresem, amelyeket 6-al oszthatóak maradék 1-el? Ez január és július esetében (1/6= 0 maradék 1) és (7/6=1 maradék 1), "yearly" pedig (1/12=0 maradék 1)?
  2c.) címkéket megszűntettem if - end if-eket használva 

  3.) hibakezelés, pl valami létfontosságú cella nincs kitöltve. Szűrést pedig úgy értem, hogy  kézzel leszűröm az adatokat, majd arra eresztem rá a makrót, hiba a Save&Close-nál van, mert olyankor is a maradék tartományt figyeli, mikor az egyébként a szűrés miatt nem látszik.

  + A kódhoz hozzáadtam egy response-t, ami a user arcába tolja, hogy a makró milyen nyomtatókat fog használni, mindkettőt le kell okézni, csak így kerül az ellenörző cellába, ahonnan a makró majd használja. Ha valamelyik cella üres, akkor a kód megáll, és informálja a usert. Ezen kívül még hozzáadtam egy manual update oszlopot is az adattáblán, alapból ki van kapcsolva, de ha "yes" az értéke, akkor csak megnyitja a workbookot, majd megy tovább a ciklus, valamint egy néhány sort, hogy szűrést és manual update-et alaphelyzetbe állítsa miután a fájl megnyílik.

  így néznek ki:

  Sub Auto_Open()

Dim start As Date
Dim weekcom As Date
Dim today As Date
Dim response As VbMsgBoxResult

Dim lo As ListObject
Dim ws As Worksheet, ma As Worksheet
Dim lastrow As Long


Set lo = Worksheets("OpenClose").ListObjects(1)
lo.AutoFilter.ShowAllData

Set ma = Workbooks("FillerPrinter.xlsm").Worksheets("MainAssembly")
'ma.Unprotect "123"

Set ws = Workbooks("FillerPrinter.xlsm").Worksheets("OpenClose")
lastrow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
ws.Range("P2:P" & lastrow) = "no"



Worksheets("MainAssembly").Activate
Range("A1").Select

start = Sheets("MainAssembly").Range("F3").Value
today = Sheets("MainAssembly").Range("F7").Value
weekcom = start
Do While weekcom < today
weekcom = weekcom + 28
Loop
Sheets("MainAssembly").Range("F6").Value = weekcom

Dim Printers() As String
Dim N As Long
Dim S As String
Dim col As String
Dim bw As String

Printers = GetPrinterFullNames()

Sheets("MainAssembly").Range("F8:F9").Value = ""


For N = LBound(Printers) To UBound(Printers)
S = Printers(N) 'S & Printers(N) & vbNewLine
If InStr(S, "Microsoft") <> 0 And InStr(S, "Print") <> 0 Then col = S
If InStr(S, "HP Photosmart Wireless B109n-z") <> 0 And InStr(S, "Print") = 0 Then bw = S
Next N

response = MsgBox(col, vbOKCancel, "Confirm the Colour Printer")
If response = vbOK Then
Sheets("MainAssembly").Range("F8").Value = col
Else: MsgBox "Stop-Call-Wait", vbOKOnly
Exit Sub
End If

response = MsgBox(bw, vbOKCancel, "Confirm the B&W Printer")
If response = vbOK Then
Sheets("MainAssembly").Range("F9").Value = bw
Else: MsgBox "Stop-Call-Wait", vbOKOnly
Exit Sub
End If
'ma.Protect "123"
End Sub

  Sub EOM_Main_Assy_Workbooks()

'loop:
Dim sPath As String, ssheet As String, fileName As String
Dim lastrow As Long, counter As Long
Dim ws As Worksheet, tp As Worksheet, ma As Worksheet
'print:
Dim bw As String, col As String
Dim toprint As Boolean
'from main worksheet:
Dim sDate As String
Dim sWeek As String
Dim sWkcom As String
Dim nextmonth As Date
'from Table:
Dim freq As String
Dim area As String
Dim loc As String
Dim dat As String
Dim week As String
Dim wkcom As String
Dim procloc As String
Dim procname As String
Dim machloc As String
Dim machname As String
Dim printer As String
Dim copies As Integer
Dim saveandclose As String
Dim manual As String
Dim manualcheck As Boolean

sDate = "=[FillerPrinter.xlsm]MainAssembly!$F$4"
sWeek = "=[FillerPrinter.xlsm]MainAssembly!$F$5"
sWkcom = "=[FillerPrinter.xlsm]MainAssembly!$F$6"

Set ma = Workbooks("FillerPrinter.xlsm").Worksheets("MainAssembly")

nextmonth = ma.Range("F4")
col = ma.Range("F9")
bw = ma.Range("F9")

'1st condition
If ma.Range("F8") = "" Or ma.Range("F9") = "" Then
MsgBox prompt:="One or both printers are not selected." & VBA.Constants.vbNewLine & "Please click on Update / Reset button!" & VBA.Constants.vbNewLine & "If not sure, please S-C-W!"
Exit Sub
End If
'End of 1st condition

Set ws = Workbooks("FillerPrinter.xlsm").Worksheets("OpenClose")

lastrow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
counter = 2
manualcheck = False

Do While counter <= lastrow

'2nd condition
If Not ws.Range("A" & counter).EntireRow.Hidden Then

freq = ws.Range("A" & counter)
area = ws.Range("B" & counter)
loc = ws.Range("C" & counter)
sPath = ws.Range("D" & counter)
ssheet = ws.Range("E" & counter)
dat = ws.Range("F" & counter)
week = ws.Range("G" & counter)
wkcom = ws.Range("H" & counter)
procloc = ws.Range("I" & counter)
procname = ws.Range("J" & counter)
machloc = ws.Range("K" & counter)
machname = ws.Range("L" & counter)
printer = ws.Range("M" & counter)
copies = ws.Range("N" & counter)
saveandclose = ws.Range("O" & counter)
manual = ws.Range("P" & counter)

'freq check

Select Case CStr(freq)
Case "4 weekly", "monthly"
toprint = True
Case "2 monthly"
toprint = Month(nextmonth) Mod 2 = 1
Case "3 monthly"
toprint = Month(nextmonth) Mod 3 = 1
Case "6 monthly"
toprint = Month(nextmonth) Mod 6 = 1
Case "yearly"
toprint = Month(nextmonth) Mod 12 = 1
End Select

'open sheets
'3rd condition
If toprint Then
Application.ScreenUpdating = True
ma.Visible = True

fileName = Right(sPath, Len(sPath) - InStrRev(sPath, "\"))
Application.StatusBar = "Processing File: " & fileName
Application.ScreenUpdating = False

Workbooks.Open sPath
Windows(fileName).Visible = False

'4th condition
If CStr(manual) = "no" Then

'update sheets if necessary
If CStr(dat) <> "" Then Workbooks(fileName).Sheets(ssheet).Range(dat).Formula = sDate
If CStr(week) <> "" Then Workbooks(fileName).Sheets(ssheet).Range(week).Formula = sWeek
If CStr(wkcom) <> "" Then Workbooks(fileName).Sheets(ssheet).Range(wkcom).Formula = sWkcom
If CStr(procloc) <> "" Then Workbooks(fileName).Sheets(ssheet).Range(procloc).Formula = procname
If CStr(machloc) <> "" Then Workbooks(fileName).Sheets(ssheet).Range(machloc).Formula = machname


'print sheets
Set tp = Workbooks(fileName).Worksheets(CStr(ssheet))

Select Case CStr(printer)
Case "col"
Application.ActivePrinter = col
tp.PrintOut copies:=CStr(copies)
Case "bw"
Application.ActivePrinter = bw
tp.PrintOut copies:=CStr(copies)
Case Else
MsgBox "No printer selected"
End Select

'wait here a bit

Do While ActiveWindow.View = xlPrint
Loop

'time to save&close
If CStr(saveandclose) = "yes" Then Excel.Workbooks(fileName).Close SaveChanges:=True



Else:
'Windows(fileName).Visible = True
manualcheck = True

'End of 4th condition
End If

'End of 3rd condition
End If

'End of 2nd condition
End If

counter = counter + 1
Loop

Application.StatusBar = "Done!"
Application.ScreenUpdating = True

ma.Activate
Range("A1").Select

If manualcheck = True Then
MsgBox "Update and print the sheets manually"
Else: MsgBox "Done!"
End If

End Sub

• #47894 Fferi50 Topikgazda eszgé100 #47881

  Új Válasz 2021-11-29 17:42:01 #47894

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Fferi50

  Topikgazda

  válasz eszgé100 #47881 üzenetére

  Szia!
  Apróságokat tennék hozzá, talán gyorsít valamit rajta:
  1. Kérdés: ahol Save&Close =no ott nem kell bezárni a fájlt? Mert ebben az esetben sok-sok fájlod nyitva fog maradni.
  Ha mégis be kell zárni, akkor
  If CStr(saveandclose) = "yes" Then
Excel.Workbooks(fileName).Close SaveChanges:=True
Else: GoTo nextraw
End If
  helyett javaslom:
  Excel.Workbooks(fileName).Close SaveChanges:= CStr(saveandclose) = "yes"
  Ha nyitva kell hagyni, akkor is elég az IF-es sor a következőképpen:
  If CStr(saveandclose) = "yes" Then Excel.Workbooks(fileName).Close SaveChanges:=True
  Nem kell hozzá ELSE és END IF.
  2. Javaslat: én nagyon nem szeretem az ugrálást makrón belül, általában mindig meg lehet oldani e nélkül a feladatot. Nálad 2 cimke van: openworksheets és nextraw.
  Egy új változó bevezetésével el lehet kerülni a cimkéhez ugrást.
  Dim nyomtatni As Boolean
  Ennek a változónak adunk értéket a Select Case utasításokon belül - ezt is egy picit egyszerűsítve:
  Select Case CStr(freq)
Case "4 weekly", "monthly"
nyomtatni = True
Case "2 monthly"
nyomtatni = Month(nextmonth) Mod 2 = 1
Case "3 monthly"
nyomtatni = Month(nextmonth) Mod 3 = 1
End Select
  A két cimke helyére pedig:
  openworksheets: helyett:
If nyomtatni Then
.
.
nextraw: helyett
End If
  Áttekinthetőbb és szerintem gyorsabb is lehet.
  3. Kérdés:
  Milyen szűrést szeretnél? Hol lenne helye a hibakezelésnek?

  Üdv.

• #47881 eszgé100 őstag Fferi50 #44543

  Új Válasz 2021-11-28 01:09:28 #47881

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  eszgé100

  őstag

  válasz Fferi50 #44543 üzenetére

  "Nem tudom hány xls-ed van, de nem hiszem, hogy mindegyiket külön-külön el kellene látni ugyanazon funkciókat végző makrókkal. Én egy alap Excelt használnék, amiben a makrók benne vannak és abból intézném az összes többinek a megnyitását és kezelését. Így csak egy fájlt kell karbantartani, nem pedig x db-ot.
  De lehet, hogy rosszul látom.
  Üdv."

  Üdv Fferi50,

  Nem láttad rosszul a dolgokat, jelenleg így állok a dologgal:

  

  

  Ez a kód lefut megnyitáskor:

  Option Explicit
Private Const HKEY_CURRENT_USER As Long = &H80000001
Private Const HKCU = HKEY_CURRENT_USER
Private Const KEY_QUERY_VALUE = &H1&
Private Const ERROR_NO_MORE_ITEMS = 259&
Private Const ERROR_MORE_DATA = 234

Private Declare PtrSafe Function RegOpenKeyEx Lib "advapi32" _
Alias "RegOpenKeyExA" ( _
ByVal HKey As Long, _
ByVal lpSubKey As String, _
ByVal ulOptions As Long, _
ByVal samDesired As Long, _
phkResult As Long) As Long

Private Declare PtrSafe Function RegEnumValue Lib "advapi32.dll" _
Alias "RegEnumValueA" ( _
ByVal HKey As Long, _
ByVal dwIndex As Long, _
ByVal lpValueName As String, _
lpcbValueName As Long, _
ByVal lpReserved As Long, _
lpType As Long, _
lpData As Byte, _
lpcbData As Long) As Long

Private Declare PtrSafe Function RegCloseKey Lib "advapi32.dll" ( _
ByVal HKey As Long) As Long
Public Function GetPrinterFullNames() As String()
Dim Printers() As String ' array of names to be returned
Dim PNdx As Long ' index into Printers()
Dim HKey As Long ' registry key handle
Dim Res As Long ' result of API calls
Dim Ndx As Long ' index for RegEnumValue
Dim ValueName As String ' name of each value in the printer key
Dim ValueNameLen As Long ' length of ValueName
Dim DataType As Long ' registry value data type
Dim ValueValue() As Byte ' byte array of registry value value
Dim ValueValueS As String ' ValueValue converted to String
Dim CommaPos As Long ' position of comma character in ValueValue
Dim ColonPos As Long ' position of colon character in ValueValue
Dim M As Long ' string index

' registry key in HCKU listing printers
Const PRINTER_KEY = "Software\Microsoft\Windows NT\CurrentVersion\Devices"

PNdx = 0
Ndx = 0
' assume printer name is less than 256 characters
ValueName = String$(256, Chr(0))
ValueNameLen = 255
' assume the port name is less than 1000 characters
ReDim ValueValue(0 To 999)
' assume there are less than 1000 printers installed
ReDim Printers(1 To 1000)

' open the key whose values enumerate installed printers
Res = RegOpenKeyEx(HKCU, PRINTER_KEY, 0&, _
KEY_QUERY_VALUE, HKey)
' start enumeration loop of printers
Res = RegEnumValue(HKey, Ndx, ValueName, _
ValueNameLen, 0&, DataType, ValueValue(0), 1000)
' loop until all values have been enumerated
Do Until Res = ERROR_NO_MORE_ITEMS
M = InStr(1, ValueName, Chr(0))
If M > 1 Then
' clean up the ValueName
ValueName = Left(ValueName, M - 1)
End If
' find position of a comma and colon in the port name
CommaPos = InStr(1, ValueValue, ",")
ColonPos = InStr(1, ValueValue, ":")
' ValueValue byte array to ValueValueS string
On Error Resume Next
ValueValueS = Mid(ValueValue, CommaPos + 1, ColonPos - CommaPos)
On Error GoTo 0
' next slot in Printers
PNdx = PNdx + 1
Printers(PNdx) = ValueName & " on " & ValueValueS
' reset some variables
ValueName = String(255, Chr(0))
ValueNameLen = 255
ReDim ValueValue(0 To 999)
ValueValueS = vbNullString
' tell RegEnumValue to get the next registry value
Ndx = Ndx + 1
' get the next printer
Res = RegEnumValue(HKey, Ndx, ValueName, ValueNameLen, _
0&, DataType, ValueValue(0), 1000)
' test for error
If (Res <> 0) And (Res <> ERROR_MORE_DATA) Then
Exit Do
End If
Loop
' shrink Printers down to used size
ReDim Preserve Printers(1 To PNdx)
Res = RegCloseKey(HKey)
' Return the result array
GetPrinterFullNames = Printers
End Function
Sub Auto_Open()

Dim start As Date
Dim weekcom As Date
Dim today As Date
start = Sheets("MainAssembly").Range("F3").Value
today = Sheets("MainAssembly").Range("F7").Value
weekcom = start
Do While weekcom < today
weekcom = weekcom + 28
Loop
Sheets("MainAssembly").Range("F6").Value = weekcom

Dim Printers() As String
Dim N As Long
Dim S As String
Dim col As String
Dim bw As String

Printers = GetPrinterFullNames()

For N = LBound(Printers) To UBound(Printers)
S = Printers(N) 'S & Printers(N) & vbNewLine
If InStr(S, "Microsoft") <> 0 And InStr(S, "Print") <> 0 Then col = S
If InStr(S, "HP Photosmart Wireless B109n-z") <> 0 And InStr(S, "Print") = 0 Then bw = S
Next N

Sheets("MainAssembly").Range("F8").Value = col
Sheets("MainAssembly").Range("F9").Value = bw

MsgBox col, vbOKOnly, "Colour Printer"
MsgBox bw, vbOKOnly, "BW Printer"

End Sub

  Ez pedig elvégzi a piszkos munkát:

  Sub EOM_Main_Assy_Workbooks()

'loop:
Dim sPath As String, ssheet As String, fileName As String
Dim lastrow As Long, counter As Long
Dim ws As Worksheet, tp As Worksheet, ma As Worksheet
'printers:
Dim bw As String, col As String
'from main worksheet:
Dim sDate As String
Dim sWeek As String
Dim sWkcom As String
Dim nextmonth As Date
'from Table:
Dim freq As String
Dim area As String
Dim loc As String
Dim dat As String
Dim week As String
Dim wkcom As String
Dim procloc As String
Dim procname As String
Dim machloc As String
Dim machname As String
Dim printer As String
Dim copies As Integer
Dim saveandclose As String


sDate = "=[FillerPrinter.xlsm]MainAssembly!$F$4"
sWeek = "=[FillerPrinter.xlsm]MainAssembly!$F$5"
sWkcom = "=[FillerPrinter.xlsm]MainAssembly!$F$6"

Set ma = Workbooks("FillerPrinter.xlsm").Worksheets("MainAssembly")

nextmonth = ma.Range("F4")
col = ma.Range("F9")
bw = ma.Range("F9")


Set ws = Workbooks("FillerPrinter.xlsm").Worksheets("OpenClose")

lastrow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
counter = 2



Do While counter <= lastrow

ws.Activate

freq = Range("A" & counter)
area = Range("B" & counter)
loc = Range("C" & counter)
sPath = Range("D" & counter)
ssheet = Range("E" & counter)
dat = Range("F" & counter)
week = Range("G" & counter)
wkcom = Range("H" & counter)
procloc = Range("I" & counter)
procname = Range("J" & counter)
machloc = Range("K" & counter)
machname = Range("L" & counter)
printer = Range("M" & counter)
copies = Range("N" & counter)
saveandclose = Range("O" & counter)



'freq check

Select Case CStr(freq)

Case "4 weekly"
GoTo openworksheets

Case "monthly"
GoTo openworksheets

Case "2 monthly"
Select Case Month(nextmonth)
Case 1, 3, 5, 7, 9, 11
GoTo openworksheets
Case Else
GoTo nextraw
End Select

Case "3 monthly"
Select Case Month(nextmonth)
Case 1, 4, 7, 10
GoTo openworksheets
Case Else
GoTo nextraw
End Select

Case Else
GoTo nextraw

End Select

'open sheets

openworksheets:
Workbooks.Open sPath

fileName = Right(sPath, Len(sPath) - InStrRev(sPath, "\"))


'update sheets if necessary

Set tp = Workbooks(fileName).Worksheets(CStr(ssheet))

If CStr(dat) <> "" Then
Sheets(ssheet).Select
Range(dat).Select
ActiveCell.Formula = sDate
End If

If CStr(week) <> "" Then
Sheets(ssheet).Select
Range(week).Select
ActiveCell.Formula = sWeek
End If

If CStr(wkcom) <> "" Then
Sheets(ssheet).Select
Range(wkcom).Select
ActiveCell.Formula = sWkcom
End If

If CStr(procloc) <> "" Then
Sheets(ssheet).Select
Range(procloc).Select
ActiveCell.Formula = procname
End If

If CStr(machloc) <> "" Then
Sheets(ssheet).Select
Range(machloc).Select
ActiveCell.Formula = machname
End If

'print sheets

Select Case CStr(printer)
Case "col"
Application.ActivePrinter = col
tp.PrintOut copies:=CStr(copies)


Case "bw"
Application.ActivePrinter = bw
tp.PrintOut copies:=CStr(copies)
Case Else
MsgBox "No printer selected"
End Select


'wait here a bit
Do While ActiveWindow.View = xlPrint
Loop

'time to save&close

If CStr(saveandclose) = "yes" Then
Excel.Workbooks(fileName).Close SaveChanges:=True
Else: GoTo nextraw
End If

nextraw:
counter = counter + 1

Loop


Worksheets("MainAssembly").Select
Range("A1").Select

MsgBox "Done!"

End Sub

  Ez nem az összes workbook, amivel foglalkoznom kell, de egyelőre tesztnek elegendőek ezek is. Jelenlegi formájában a kód 88 sheetet kevesebb, mint 2 perc alatt megnyitott, update-elt, nyomtatóra küldött, majd bezárt

  Már csak szűrést és hibakezelést kellene beleszőnöm valahogy.
  Az egész csoportnak köszönöm mégegyszer az eddigi segítséget

• #47878 eszgé100 őstag Delila_1 #47877

  Új Válasz 2021-11-26 21:50:30 #47878

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  eszgé100

  őstag

  válasz Delila_1 #47877 üzenetére

  Köszönöm, de nem pontosan ilyen formában kerestem a duplikációt.
  Van egy vba ciklusom, fentről lefelé halad, ezért nem releváns, hogy a tartomány felső részében található-e a duplikáció, lényeg, hogy a maradékban ne legyen, erre tökéletes volt Pakliman formulája, szerencsére működik ez is automatikusan, ha táblává alakítom. egyébként örök hálám az ötletért, megmentettél egy kör guglizástól

  Valós felhasználása egyébként az lesz, hogy B oszlopban lesznek elérési útvonalak, többi oszlopban különböző paraméterek a ciklusnak, és az utolsó oszlopban lesznek tárolva a válaszok a Save&Close-ra. Ha az adott fájlt később még használja a ciklus, akkor nyitva hagyom (válasz no), ha nem akkor mentés és zárás (yes), példában pont fordítva kérdeztem, de az már csak részletkérdés.

  Ezzel kapcsolatban meg is érkeztem ma esti fejtörőmhöz:

  Ciklusomban egy bizonyos ponton elérkezek a nyomtatáshoz

  Select Case CStr(printer)
            Case "col"
                Application.ActivePrinter = col
              tp.PrintOut copies:=CStr(copies)
            Case "bw"
                Application.ActivePrinter = bw
                tp.PrintOut copies:=CStr(copies)
            Case Else
                MsgBox "No printer selected"
        End Select

  Majd ezután megvizsgálom, hogy Save&Close "yes"-e?

  If CStr(saveandclose) = "yes" Then
            Excel.Workbooks(fileName).Close SaveChanges:=True
            Else: GoTo nextraw
            End If
  
  Itt kezdődnek a bajok, a kettő közé kellene valami, ami megakasztja a cilkus további futását, amíg ez az ablak be nem záródik.

  

  Ugyanis, ha várni kell a nyomtatóra valamiért, akkor az ciklus egyszerűen bezárja a fájlom még mielőtt el lett volna küldve a nyomtatóra.

  Próbáltam ezt, wordben ok, de sajnos excelben nem működik:

  While Application.backgroundPrintingStatus > 0
        Application.Wait (Now + TimeValue("00:00:01"))
Wend

  Simán Application.Wait-et sem akarok használni, mert akkor 1000 évig tartana, míg végez a ciklus, plusz azt sem tudom mennyi időt kellene pontosan meghatároznom.

• #47661 Fire/SOUL/CD félisten eszgé100 #47660

  Új Válasz 2021-10-29 21:48:59 #47661

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Fire/SOUL/CD

  félisten

  válasz eszgé100 #47660 üzenetére

  A megoldást már más megírta, úgy hogy csak INNEN bemásolom a kódot.
  Annyi módosítást hajtottam csak végre a kódban, hogy a 3 db privát funkció deklarációban beleírtam a PtrSafe tulajdonságot, mivel enélkül 64 bites rendszer alatt nem futna le a kód.

  Module1-be kerülő kód:

  Option Explicit
Private Const HKEY_CURRENT_USER As Long = &H80000001
Private Const HKCU = HKEY_CURRENT_USER
Private Const KEY_QUERY_VALUE = &H1&
Private Const ERROR_NO_MORE_ITEMS = 259&
Private Const ERROR_MORE_DATA = 234

Private Declare PtrSafe Function RegOpenKeyEx Lib "advapi32" _
Alias "RegOpenKeyExA" ( _
ByVal HKey As Long, _
ByVal lpSubKey As String, _
ByVal ulOptions As Long, _
ByVal samDesired As Long, _
phkResult As Long) As Long

Private Declare PtrSafe Function RegEnumValue Lib "advapi32.dll" _
Alias "RegEnumValueA" ( _
ByVal HKey As Long, _
ByVal dwIndex As Long, _
ByVal lpValueName As String, _
lpcbValueName As Long, _
ByVal lpReserved As Long, _
lpType As Long, _
lpData As Byte, _
lpcbData As Long) As Long

Private Declare PtrSafe Function RegCloseKey Lib "advapi32.dll" ( _
ByVal HKey As Long) As Long

Public Function GetPrinterFullNames() As String()
Dim Printers() As String ' array of names to be returned
Dim PNdx As Long ' index into Printers()
Dim HKey As Long ' registry key handle
Dim Res As Long ' result of API calls
Dim Ndx As Long ' index for RegEnumValue
Dim ValueName As String ' name of each value in the printer key
Dim ValueNameLen As Long ' length of ValueName
Dim DataType As Long ' registry value data type
Dim ValueValue() As Byte ' byte array of registry value value
Dim ValueValueS As String ' ValueValue converted to String
Dim CommaPos As Long ' position of comma character in ValueValue
Dim ColonPos As Long ' position of colon character in ValueValue
Dim M As Long ' string index

' registry key in HCKU listing printers
Const PRINTER_KEY = "Software\Microsoft\Windows NT\CurrentVersion\Devices"

PNdx = 0
Ndx = 0
' assume printer name is less than 256 characters
ValueName = String$(256, Chr(0))
ValueNameLen = 255
' assume the port name is less than 1000 characters
ReDim ValueValue(0 To 999)
' assume there are less than 1000 printers installed
ReDim Printers(1 To 1000)

' open the key whose values enumerate installed printers
Res = RegOpenKeyEx(HKCU, PRINTER_KEY, 0&, _
KEY_QUERY_VALUE, HKey)
' start enumeration loop of printers
Res = RegEnumValue(HKey, Ndx, ValueName, _
ValueNameLen, 0&, DataType, ValueValue(0), 1000)
' loop until all values have been enumerated
Do Until Res = ERROR_NO_MORE_ITEMS
M = InStr(1, ValueName, Chr(0))
If M > 1 Then
' clean up the ValueName
ValueName = Left(ValueName, M - 1)
End If
' find position of a comma and colon in the port name
CommaPos = InStr(1, ValueValue, ",")
ColonPos = InStr(1, ValueValue, ":")
' ValueValue byte array to ValueValueS string
On Error Resume Next
ValueValueS = Mid(ValueValue, CommaPos + 1, ColonPos - CommaPos)
On Error GoTo 0
' next slot in Printers
PNdx = PNdx + 1
Printers(PNdx) = ValueName & " on " & ValueValueS
' reset some variables
ValueName = String(255, Chr(0))
ValueNameLen = 255
ReDim ValueValue(0 To 999)
ValueValueS = vbNullString
' tell RegEnumValue to get the next registry value
Ndx = Ndx + 1
' get the next printer
Res = RegEnumValue(HKey, Ndx, ValueName, ValueNameLen, _
0&, DataType, ValueValue(0), 1000)
' test for error
If (Res <> 0) And (Res <> ERROR_MORE_DATA) Then
Exit Do
End If
Loop
' shrink Printers down to used size
ReDim Preserve Printers(1 To PNdx)
Res = RegCloseKey(HKey)
' Return the result array
GetPrinterFullNames = Printers
End Function

Sub Test()
Dim Printers() As String
Dim N As Long
Dim S As String
Printers = GetPrinterFullNames()
For N = LBound(Printers) To UBound(Printers)
S = S & Printers(N) & vbNewLine
Next N
MsgBox S, vbOKOnly, "Printers"
End Sub

  Eredménye (most az Én gépemen futtatva)

  

  Nyilván esetedben annyiban kell módosítani pluszban a kódot, hogy ne a képernyőre irogassa ki az összes nyomtatót, hanem a cikluson belül, megvizsgálod, hogy az aktuális printer neve tratalmazza-e az általad használt 2 printer nevének egyikét, ha igen, akkor "elévarázsololod" a \\ jelet és a megfelelő változódnak meg is van az értéke és kb. meg is vagy.

• #47641 ReSeTer senior tag

  Új Válasz 2021-10-25 09:12:12 #47641

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  ReSeTer

  senior tag

  Helló!

  Egyszerűen nem tudok rájönni, hogy miért működik első ciklusban az egész, majd amikor az első ismétlés elkezdődik, hibára fut:

    holkeressen = "A1:A1000"
    
  For megintismetel = 1 To 3
  talalatsorszama = Application.Match(munkaszam, Range(holkeressen), 0)
    holkeressen = "A" & talalatsorszama + 1 & ":A1000"
If VarType(talalatsorszama) = vbError Then
    MsgBox " nincs talalat", vbInformation, "Hiba"
 Else
  MsgBox "cella tartalmának sorszáma az A oszlopban: " & talalatsorszama, vbInformation, "Eredmény üzenet"
  End If
On Error GoTo
Egyéb kód itt
Next megintismetel

  A cél az, hogy addig ismételje, amíg van találat, de próbaképp csak 3x akarom ismételni, majd később átírom. De így se fut le. Elvileg át kellene írnia mindig a keresési tartomány elejét az "előző találat+1"-re, hogy ne számolja bele az előbbi találat.

  Hibaüzenet: Runtime error '13'
  Type Mismatch

  Amikor debug módban rámutatok egérrel a talalatsorszama-ra akkor: Error 2042 az értéke

  Mi lehet a probléma?

• #47619 Delila_1 veterán ReSeTer #47617

  Új Válasz 2021-10-20 11:27:05 #47619

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Delila_1

  veterán

  válasz ReSeTer #47617 üzenetére

  Betettem két soremelést az Else ágba, hogy feltünőbb legyen a sorszám.

  Sub Talalat()
    Dim talal
    On Error Resume Next
    Columns(2).ClearContents 'A későbbi beírás miatt törlöm a B oszlop adatait
    talal = Application.Match(Range("G1"), Columns(1), 0)
    If VarType(talal) = vbError Then
        MsgBox "Nem található a G1 cella értéke az A oszlopban", vbInformation, "Hiányzó szöveg"
        On Error GoTo 0
    Else
        MsgBox "G1 cella tartalmának sorszáma az A oszlopban: " & vbLf & vbLf & talal, vbInformation, "Sorszám"
        
        'Itt felhasználjuk a talal változó értékét
      Range("B" & talal) = "Ebben a sorban van a G1 cella értéke"
    End If
End Sub
  

• #47612 Delila_1 veterán ReSeTer #47611

  Új Válasz 2021-10-19 13:48:06 #47612

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Delila_1

  veterán

  válasz ReSeTer #47611 üzenetére

  Sub Talalat()
    Dim talal
    On Error Resume Next
    talal = Application.Match(Range("G1"), Columns(1), 0)
    If VarType(talal) = vbError Then
        MsgBox "Nem található a G1 cella értéke az A oszlopban", vbInformation, "Hiányzó szöveg"
    Else
        MsgBox "G1 cella tartalmának sorszáma az A oszlopban: " & talal, vbInformation, "Sorszám"
    End If
    On Error GoTo 0
End Sub

• #47388 Sprite75 tag

  Új Válasz 2021-09-15 13:56:28 #47388

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Sprite75

  tag

  Sziasztok

  Van egy ilyen kód az egyik táblázatomban a Rendelés lapon ami egy Combo boxban történő keresést működtet.
  
  Private Sub ComboBox1_Change()
    Dim i As Long
    
      If Not IsArrow Then
        With Me.ComboBox1
            .List = Worksheets("Rendelés").Range("BD5", Worksheets("Rendelés").Cells(Rows.Count, "BD").End(xlUp)).Value
            .ListRows = Application.WorksheetFunction.Min(20, .ListCount)
            .DropDown
            If Len(.Text) Then
                For i = .ListCount - 1 To 0 Step -1
                    If InStr(1, .List(i), .Text, vbTextCompare) = 0 Then .RemoveItem i
                Next
                .DropDown
            End If
        End With
    End If
    
    On Error Resume Next
    i = Application.Match(Cells(1, 1), Columns(2), 0)
    If Not VarType(i) = vbError Then Cells(i, 3).Select
    On Error GoTo 0
   
   
End Sub

Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    IsArrow = (KeyCode = vbKeyUp) Or (KeyCode = vbKeyDown)
    If KeyCode = vbKeyReturn Then Me.ComboBox1.List = Worksheets("Rendelés").Range("BD5", Worksheets("Rendelés").Cells(Rows.Count, "BD").End(xlUp)).Value
End Sub

Private Sub ComboBox1_DropButtonClick()
    With Me.ComboBox1
        .List = Worksheets("Rendelés").Range("BD5", Worksheets("Rendelés").Cells(Rows.Count, "BD").End(xlUp)).Value
        .ListRows = Application.WorksheetFunction.Min(20, .ListCount)
        .DropDown
    End With
End Sub

  Viszont ugyanebben a táblázatban fut egy ilyen kód ami a táblázat 2 különböző lapjának PDF-be történő mentését futtatja 20 percennénk.

  Sub TimerPDFStart()
    If kovidoPDF > Now Then Exit Sub
    kovidoPDF = Now + TimeSerial(0, 20, 0)   '1 perces időzítési idő
    Application.OnTime kovidoPDF, "PDFautoment", , True
End Sub

  A problémám az, hogy ha épp nyitva van a Combo box, ép pont akkor jár le a 20 merc amikor a PDFautoment makró lefutna, akkor hibát amikor a PDFautoment át akar lépni egy másik munkalapra, hogy mentsen PDF-be (Sheets("Összesítve").Select)

  Meg lehet azt oldani hogy ha nyitva van a Combo box és épp akkor indítaná a TimerPDFStart() időzítő a mentést akkor az várakozzon amíg a combo box használata be nem fejeződik.

  Bocsi hogy egy kicsit hosszú lett.

• #47244 Fferi50 Topikgazda andreas49 #47243

  Új Válasz 2021-08-17 14:49:48 #47244

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Fferi50

  Topikgazda

  válasz andreas49 #47243 üzenetére

  Szia!
  Ezt a makrót másold be egy modulba (vagy a munkalap kódlapjára).
  Sub kerescserel()
Dim wb As Workbook, ws As Worksheet, mit, mire
On Error GoTo hibas
mit = "": mire = ""
mit = Application.InputBox("Mit cseréljek", "Cserélés", mit)
If mit <> "" And mit <> "False" Then
mire = Application.InputBox("Mire cseréljem a: " & mit & " szöveget?", "Cserélés", mire)
If mire <> "" And mire <> "False" Then
Application.ScreenUpdating = False
For Each wb In Workbooks
For Each ws In Worksheets
ws.UsedRange.Replace what:=mit, replacement:=mire, lookat:=xlWhole
Next
Application.StatusBar = "Cserélem a " & mit & " " & mire & "a(z) " & wb.Name & " munkafüzetben!"
DoEvents
Next
End If
End If
Application.ScreenUpdating = True
Application.StatusBar = False
Exit Sub
hibas:
MsgBox "Hiba van: " & Error
End Sub
  Meg kell adnod, hogy mit cseréljen, majd azt, hogy mire szeretnéd cserélni.
  A cserélés csak teljes cellatartalomra vonatkozik, részekre nem. Nem érzékeny a kisbetű-nagybetű különbségre.
  A makró minden nyitott munkafüzet minden munkalapján cseréli az adott szöveget.
  Hozzá rendelheted egy billentyű kombinációhoz, akkor azzal gyorsan tudod hívni - vagy felteheted a menüszalagra is a beállítások - menüszalag - makrók útján.
  Ha hibával megáll, akkor jelezz vissza légy szíves.
  Remélem, tudod használni.
  Üdv.

• #46720 lappy őstag

  Új Válasz 2021-05-20 12:57:01 #46720

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  lappy

  őstag

  legördülő lista több elem kiválasztása esetén ezzel a kóddal lehetne, de nem működik és nem tudom miért
  ha vki ránézne köszönöm
  Option Explicit

  Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rngDV As Range
  Dim oldVal As String
  Dim newVal As String
  Dim strVal As String
  Dim i As Long
  Dim lCount As Long
  Dim Ar As Variant
  On Error Resume Next
  Dim lType As Long
  If Target.Count > 1 Then GoTo exitHandler

  lType = Target.Validation.Type
  If lType = 3 Then
  Application.EnableEvents = False
  newVal = Target.Value
  Application.Undo
  oldval = Target.Value
  Target.Value = newVal
  If Target.Column = 3 Then
  If oldVal = "" Then
  Else
  If newVal = "" Then
  Else
  On Error Resume Next
  Ar = Split(oldVal, ", ")
  strVal = ""
  For i = LBound(Ar) To UBound(Ar)
  Debug.Print strVal
  Debug.Print CStr(Ar(i))
  If newVal = CStr(Ar(i)) Then
  strVal = strVal
  lCount = 1
  Else
  strVal = strVal & CStr(Ar(i)) & ", "
  End If
  Next i
  If lCount > 0 Then
  Target.Value = Left(strVal, Len(strVal) - 2)
  Else
  Target.Value = strVal & newVal
  End If
  End If
  End If
  End If
  End If

  exitHandler:
  Application.EnableEvents = True
  End Sub

• #46565 logitechh csendes tag logitechh #46561

  Új Válasz 2021-05-03 22:44:05 #46565

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  logitechh

  csendes tag

  válasz logitechh #46561 üzenetére

  Sziasztok!

  Összetákoltam valait de sajnos valami nem ok.
  Össze vissza megismétli a nevet és nem mindig abba a mappába ment ahová kellene hanem egyel kijjebb majd ismét egy mappával kijjebb
  
  Esetleg valaki tudja hol ronthattam el?

  Sub AutomatikusMentes()
ActiveSheetExportToTXT
MunkalapAtnevez
ActiveSheetExportToXLSM
End Sub
Sub MunkalapAtnevez()

Dim strMunkalapNev As String 'hely foglalás a memóriában
strMunkalapNev = "létszámjelentő" 'név deklarálása
ActiveSheet.Select 'aktív munkalap kijelölése
ActiveSheet.Name = strMunkalapNev 'aktív munkalap neének megadása a deklarált név alapján
End Sub
Sub ActiveSheetExportToTXT()
'aktív munkalap lementése a név:a munkafüzet neve_létszám_dátum_óra perc_másodperc
cntr = ""
If Dir(ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1)) & "_Dezsike_" & cntr & ".txt") = "" Then GoTo xprt
If Dir(ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1)) & "_Dezsike_" & cntr & ".txt") <> "" Then
cntr = 1
Do Until Dir(ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1)) & "_Dezsike_" & cntr & ".txt") = ""
cntr = cntr + 1
Loop
End If
xprt:
ActiveWorkbook.SaveAs filename:= _
ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1)) & "_Dezsike_" & Format(Now, "yyyymmdd_hhnn_ss") & ".txt", _
FileFormat:=xlText, _
CreateBackup:=False
End Sub
Sub ActiveSheetExportToXLSM()
'aktív munkalap lementése a név:a munkafüzet neve_létszám_dátum_óra perc_másodperc
cntr = ""
If Dir(ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1)) & "Létszámjelentő" & cntr & ".xlsm") = "" Then GoTo xprt
If Dir(ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1)) & "Létszámjelentő" & cntr & ".xlsm") <> "" Then
cntr = 1
Do Until Dir(ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1)) & "Létszámjelentő" & cntr & ".xlsm") = ""
cntr = cntr + 1
Loop
End If
xprt:
ActiveWorkbook.SaveAs filename:= _
ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1)) & "Létszámjelentő" & Format(Now, "yyyymmdd_hhnn_ss") & ".xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
End Sub

• #46469 spe88 senior tag

  Új Válasz 2021-04-16 10:50:10 #46469

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  spe88

  senior tag

  Ismét kéne egy kis segítség. Van egy PDF-küldős makróm.

  Az alábbi pontokkal szembesülök.

  1. Az A1 cellában egy hiperhivatkozás van. A PDF-ben ez nem jelenik meg, csak mint szöveg látom.
  2. Az Outlook-üzenet első sora nem "Hallo Kollegen" ahogy megadtam, hanem "FalseHallo Kollegen"
  2. Az e-mail törzsben az első sor ( "FalseHallo Kollegen") az Times New Roman 12-es betűméret, míg a 2-3. sor 9-es betűméret Calibri.

  Megadtam milyen legyen a betűtípus a makróban és mégsem olyan. Illetve alapból Arial 10-es a betűtípus az e-mail-írásnál, szóval nem értem miért változtatja random Times New Romanra meg Calibrire.

  Köszönöm

  A makró:

  
  Sub SendPDF_WithAccountSignatiure()
 
  ' --> User settings, change to suit
  Const IsDisplay As Boolean = True  ' Change to False for .Send instead of .Display
  Const IsSilent As Boolean = False  ' Change to True to show Send status
  Const FontName = "Arial"           ' Font name of the email body
  Const FontSize = 11                ' Font size of the email body
  Const Account = 1                  ' Index or Name of the account to send from
  ' <-- End of the settings
 
  Dim IsCreated As Boolean
  Dim OutlApp As Object
  Dim char As Variant
  Dim PdfFile As String, HtmlFont As String, HtmlBody As String, HtmlSignature As String
 
  ' Edit the body's html text as required
  ' The tags are: h3 is for Header#3; b is for Bold; br is for line break
  HtmlBody = "Hallo Kollegen, <br>" _
           & "<br>" _
           & "Im Anhang sehen Sie die aktuelle PIP-Liste von BOS MOS."
 
  ' Set the font for the html-body (parentheses are just because of MrExcel posting limitation)
  HtmlFont = HtmlFont = "<body font: " & 11 & "pt " & Arial & ";color:black"">"
 
  ' Define PDF filename
  PdfFile = Range("'help_MOS'!an1")
 
  ' Replace illegal symbols in PdfFile by underscore
  For Each char In Split("? "" / \ < > * | :")
    PdfFile = Replace(PdfFile, char, "_")
  Next
 
  ' Apply %TEMP% path to the file name
  PdfFile = Environ("F:\03_PROJEKTE\02_BOS\2.4 SERIENBETREUUNG") & PdfFile & ".pdf"
   
  ' Try to delete PDF file if present
  If Len(Dir(PdfFile)) Then Kill PdfFile
 
  ' Export the specific worksheet as PDF
  With Worksheets("Report MOS")
    .ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
  End With
 
  ' Use the already open Outlook if possible
  On Error Resume Next
  Set OutlApp = GetObject(, "Outlook.Application")
  If Err Then
    Set OutlApp = CreateObject("Outlook.Application")
    IsCreated = True
  End If
  OutlApp.Visible = True
  On Error GoTo 0
 
  ' Prepare email with PDF attachment and the default signature
  With OutlApp.CreateItem(0)
 
    ' Set HTML format
    .BodyFormat = 2
    
    ' Add the attachment first for correct attachment's name with non English symbols
    .Attachments.Add PdfFile
 
    ' Set the required account by const Account
    Set .SendUsingAccount = OutlApp.Session.Accounts.Item(Account)
   
    ' Get default email signature without blinking (instead of .Display method)
    With .GetInspector: End With
    HtmlSignature = .HtmlBody
  
    ' Prepare e-mail
    .Subject = Range("'help_MOS'!an1")
    .To = Range("'help_MOS'!an2") ' <-- Put email of the recipient here
    .HtmlBody = HtmlFont & HtmlBody & HtmlSignature
          
    ' Try to send or just display the e-mail
    On Error Resume Next
    If IsDisplay Then .Display Else .Send
 
    ' Show error of the .Send method
    If Not IsDisplay Then
      ' Return focus to Excel's window
      Application.Visible = True
      ' Show error/success message
      If Err Then
        MsgBox "E-mail was not sent for some reasons" & vbLf & "Please check it", vbExclamation
        .Display
      Else
        If Not IsSilent Then
          MsgBox "E-mail successfully sent", vbInformation
        End If
      End If
    End If
    On Error GoTo 0
 
  End With
 
  ' Try to quit Outlook if it was not previously open
  If IsCreated Then OutlApp.Quit
 
  ' Try to release the memory of object variable
  Set OutlApp = Nothing
 
End Sub
  

• #46447 spe88 senior tag Pakliman #46446

  Új Válasz 2021-04-14 15:19:41 #46447

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  spe88

  senior tag

  válasz Pakliman #46446 üzenetére

  az enyém ilyen, de nem értem ott mi a baj. Igaz nem is értek hozzá túlzottan

  Sub SendPDF_WithAccountSignatiure()

  ' --> User settings, change to suit
Const IsDisplay As Boolean = True ' Change to False for .Send instead of .Display
Const IsSilent As Boolean = False ' Change to True to show Send status
Const FontName = "Arial" ' Font name of the email body
Const FontSize = 11 ' Font size of the email body
Const Account = 2 ' Index or Name of the account to send from
' <-- End of the settings

  Dim IsCreated As Boolean
Dim OutlApp As Object
Dim char As Variant
Dim PdfFile As String, HtmlFont As String, HtmlBody As String, HtmlSignature As String

  ' Edit the body's html text as required
' The tags are: h3 is for Header#3; b is for Bold; br is for line break
' HTML tag's are not displayed properly in the post of MrExcel forum, thus replacing is used to fix this problem
HtmlBody = "Hello, (br)" _
& ".(br)" _
& "Proba."
HtmlBody = Replace(HtmlBody, "(", "<")
HtmlBody = Replace(HtmlBody, ")", ">")

  ' Set the font for the html-body (parentheses are just because of MrExcel posting limitation)
HtmlFont = HtmlFont = "(body font: " & 11 & "pt " & Arial & ";color:black"")"
HtmlFont = Replace(HtmlFont, "(", "<")
HtmlFont = Replace(HtmlFont, ")", ">")

  ' Define PDF filename
PdfFile = Range("'Report MOS'!L1")

  ' Replace illegal symbols in PdfFile by underscore
For Each char In Split("? "" / \ < > * | :")
PdfFile = Replace(PdfFile, char, "_")
Next

  ' Apply %TEMP% path to the file name and limit lenght of the pathname
PdfFile = Environ("F:\03_PROJEKTE\02_BOS\2.4 SERIENBETREUUNG") & PdfFile & ".pdf"

  ' Try to delete PDF file if present
If Len(Dir(PdfFile)) Then Kill PdfFile

  ' Export the activesheet as PDF
With Worksheets("Report MOS")
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With

  ' Use the already open Outlook if possible
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
OutlApp.Visible = True
On Error GoTo 0

  ' Prepare email with PDF attachment and the default signature
With OutlApp.CreateItem(0)

  ' Set HTML format
.BodyFormat = 2

  ' Add the attachment first for correct attachment's name with non English symbols
.Attachments.Add PdfFile

  ' Set the required account by const Account
Set .SendUsingAccount = OutlApp.Session.Accounts.Item(Account)

  ' Get default email signature without blinking (instead of .Display method)
With .GetInspector: End With
HtmlSignature = .HtmlBody

  ' Prepare e-mail
.Subject = Range("'Report MOS'!L1")
.To = Range("'Report MOS'!L2") ' <-- Put email of the recipient here
.HtmlBody = HtmlFont & HtmlBody & HtmlSignature

  ' Try to send or just display the e-mail
On Error Resume Next
If IsDisplay Then .Display Else .Send

  ' Show error of the .Send method
If Not IsDisplay Then
' Return focus to Excel's window
Application.Visible = True
' Show error/success message
If Err Then
MsgBox "E-mail was not sent for some reasons" & vbLf & "Please check it", vbExclamation
.Display
Else
If Not IsSilent Then
MsgBox "E-mail successfully sent", vbInformation
End If
End If
End If
On Error GoTo 0

  End With

  ' Try to quit Outlook if it was not previously open
If IsCreated Then OutlApp.Quit

  ' Try to release the memory of object variable
Set OutlApp = Nothing

  End Sub

• #46446 Pakliman tag spe88 #46445

  Új Válasz 2021-04-14 14:49:36 #46446

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Pakliman

  tag

  válasz spe88 #46445 üzenetére

  Igen, arra rájöttem, hogy el is akarod küldeni, csak a PDF készítésnek és a küldésnek nincs köze egymáshoz.
  Mondjuk úgy, hogy kicsit kötözködtem Veled

  Én céges gépen vagyok, automatikusan küldök ki címekre automatikusan generált pdf fájlokat, de ilyen hibával nem találkoztam.
  Tény, hogy nálam nincs a kódban Account-ot kérő sor.
  Ha érdekel, én egy ilyen eljárást hoztam össze:
  Public Sub SendEmail( _
xTo As String, _
xSubject As String, _
Optional xCC As String = "", _
Optional xBCC As String = "", _
Optional xBody As String = "", _
Optional xHTMLBody As Variant = "", _
Optional bSend As Boolean = False, _
Optional bTörölniKüldésUtán As Boolean = False, _
Optional vFiles As Variant = Empty _
)
Const olFolderSentMail As Long = 5
Const olByValue As Long = 1
Dim OutApp As Object
Dim OutMail As Object
Dim oFolder As Object
Dim oEditor As Object
Dim cFile As Long
Dim sBody As String

If (xTo <> "") And (xSubject <> "") Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
.To = xTo
.cc = xCC
.BCC = xBCC
.Subject = xSubject
If TypeName(xHTMLBody) = "Range" Then
xHTMLBody.Copy
Set oEditor = .GetInspector.WordEditor
oEditor.Content.Paste
Else
sBody = IIf(xHTMLBody = "", xBody, xHTMLBody): If sBody = "" Then sBody = " "
.HTMLBody = sBody
End If

If IsArray(vFiles) Then
For cFile = LBound(vFiles) To UBound(vFiles)
If Dir(vFiles(cFile)) <> "" Then .Attachments.Add (vFiles(cFile)) 'Source:=vFiles(cFile), Type:=olByValue
Next cFile
Else
If Dir(vFiles) <> "" Then .Attachments.Add (vFiles) 'Source:=vFiles, Type:=olByValue
End If

If bSend Then
.DeleteAfterSubmit = bTörölniKüldésUtán
.Send
Else
.Display
End If
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing
End If
End Sub

• #46346 lcdtv tag

  Új Válasz 2021-03-30 13:52:16 #46346

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  lcdtv

  tag

  Ha valakinek kellene. A cellatartalom hyperlink kell, hogy legyen (ez nálam hiba volt), mivel több száz F2+entert nem akartam nyomogatni ezért van ez a script. Ez minden cella adatból hyperlinket csinál.
  Sub HyperAdd()
'Converts each text hyperlink selected into a working hyperlink

Dim xCell As Range

For Each xCell In Selection
ActiveSheet.Hyperlinks.Add Anchor:=xCell, Address:=xCell.Formula
Next xCell
End Sub
  majd ez a script meg letölti egy adott könyvtárba
  Const TargetFolder = "C:\temp\"
#If VBA7 And Win64 Then
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" ( _
ByVal pCaller As LongPtr, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As LongPtr, _
ByVal lpfnCB As LongPtr _
) As Long
Private Declare PtrSafe Function DeleteUrlCacheEntry Lib "Wininet.dll" _
Alias "DeleteUrlCacheEntryA" ( _
ByVal lpszUrlName As String _
) As Long
#Else
Private Declare Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" ( _
ByVal pCaller As Long, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long _
) As Long
Private Declare Function DeleteUrlCacheEntry Lib "Wininet.dll" _
Alias "DeleteUrlCacheEntryA" ( _
ByVal lpszUrlName As String _
) As Long
#End If

Public Const ERROR_SUCCESS As Long = 0
Public Const BINDF_GETNEWESTVERSION As Long = &H10
Public Const INTERNET_FLAG_RELOAD As Long = &H80000000
Public Const folderName As String = "c:\temp\"

Sub MyFileDownload()
For Each Hyperlink In ActiveSheet.Hyperlinks
For N = Len(Hyperlink.Address) To 1 Step -1
If Mid(Hyperlink.Address, N, 1) <> "/" Then
LocalFileName = Mid(Hyperlink.Address, N, 1) & LocalFileName
Else
Exit For
End If
Next N
Call HTTPDownloadFile(Hyperlink.Address, TargetFolder & LocalFileName)
LocalFileName = “”
Next Hyperlink

End Sub

Sub HTTPDownloadFile(ByVal URL As String, ByVal LocalFileName As String)
Dim Res As Long
On Error Resume Next
Kill LocalFileName
On Error GoTo 0
Res = URLDownloadToFile(0&, URL, LocalFileName, 0&, 0&)
End Sub
Sub bcvb()
End Sub

• #45500 Delila_1 veterán Lokids #45498

  Új Válasz 2020-12-04 18:06:18 #45500

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Delila_1

  veterán

  válasz Lokids #45498 üzenetére

  Az előbb a képlet helyét rosszul írtam, az 1. ws lap D5 cellájába kell írni.

  Makróval:
  Sub Masolas()
Dim sor As Integer, IttVan As Variant

Sheets("1. ws").Select
For sor = 5 To 1500
On Error Resume Next
IttVan = Application.Match(Cells(sor, 1), Sheets("2. ws").Columns(1), 0)
If VarType(IttVan) = vbError Then
On Error GoTo 0
Else
Sheets("2. ws").Range("B" & IttVan & ":E" & IttVan).Copy Cells(sor, 4)
End If
Next
End Sub

• #45399 Delila_1 veterán Fferi50 #45398

  Új Válasz 2020-11-21 06:28:19 #45399

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Delila_1

  veterán

  válasz Fferi50 #45398 üzenetére

  Hát még, ha tagolva lenne a makró! Akkor látszana, ki kivel van.

  Function Poisson2(Feltétel2 As Range) As Long
Call kep_ki
Application.Volatile 'Prohardver Delila_1 nyomán
k = 0
Kezd = Cells(8, 7) 'Feltétel kezdete oszlop
Kezd5 = Kezd + 5 'Javasolt számok terület előtti oszlop száma
Kezd22 = Kezd + 22 'Feltételek a javaslat válogatásához
a = Cells(12, Kezd) 'A munkatábla kezdő előtti oszlop száma
Előford = Kezd + a 'K(i) táblázat kezdő előtti oszlop száma
Valószín = Előford + 90 'P(x=1) táblázat kezdő előtti oszlop száma
Várak = Valószín + 90 'n(i) táblázat kezdő előtti oszlop száma
Us = Cells(4, 7) + Cells(2, 7) 'Táblázat utolsó sora
Cikl = Cells(5, Előford + 1) 'A számolás kezdete sor
Cells(6, Előford + 1) = Cikl 'Ez lesz a Ciklusváltozó kezdete
Range(Cells(Cikl + 1, Kezd + 1), Cells(Us, Kezd + 15)).ClearContents 'számítása sorok törlése
Range(Cells(Cikl, Előford + 1), Cells(Us, Valószín)).ClearContents 'K(i) táblázat törlése
Range(Cells(8, Előford + 1), Cells(8, Valószín)).Value = _
Range(Cells(Cikl - 1, Várak + 1), Cells(Cikl - 1, Várak + 90)).Value 'Az n(i-1) sor feltöltése
Cells(14, Előford + 1).Formula = Cells(14, Kezd + 49).Formula
Cells(14, Előford + 1).Select 'Kijelölés kitöltéshez
Selection.AutoFill Destination:=Range(Cells(14, Előford + 1), Cells(14, Valószín)), Type:=xlFillDefault
'Feltételek
Range("AF11:AJ11").Value = Range("AF4:AJ4").Value 'Manuális számítás
'Calculate 'A munkalapfüggvények számolása
For Cikl = Cells(6, Előford + 1) To Us 'Az utolsó + 1-ig
'1. : 'Az n(i-1) és az előző ciklusban kitörölt képletek újrafelépítése a Tartalék raktárcellából BF14
Range(Cells(8, Előford + 1), Cells(8, Valószín)).Value = _
Range(Cells(Cikl - 1, Várak + 1), Cells(Cikl - 1, Várak + 90)).Value 'Az n(i-1) sor feltöltése
Cells(14, Előford + 1).Formula = Cells(14, Kezd + 49).Formula 'Képlet
Cells(14, Előford + 1).Select 'Kijelölés kitöltéshez
Selection.AutoFill Destination:=Range(Cells(14, Előford + 1), Cells(14, Valószín)), Type:=xlFillDefault
'[P(x=1) 13-dik sor]
For i = 1 To 5
For j = 1 To 90
Calculate 'A munkalapfüggvények kiszámolják a 14-dik
If Cells(13, Előford + j) <= Cells(11, Kezd22 + i) And Cells(14, Előford + j) Then
For k = 1 To 5
If Cells(14, Előford + j) = Cells(Cikl, Kezd5 + k) Then GoTo Köv
Next k
Cells(Cikl, Kezd5 + Cells(17, Kezd5 + i)) = Cells(14, Előford + j)
Cells(Cikl, Kezd + 10 + Cells(17, Kezd5 + i)) = Cells(13, Előford + j)
Cells(14, Előford + j) = ""
j = 90
End If
Köv:
Next j
Next i
'2.
Cells(6, Előford + 1) = Cikl
'Calculate 'A munkalapfüggvények számolása
If Cells(Cikl, 4) Then
For j = 1 To 5
Cells(Cikl, Kezd + j) = Cells(12, Előford + Cells(Cikl, 3 + j))
Next j
End If
'Calculate 'A munkalapfüggvények számolása
Range(Cells(Cikl, Előford + 1), Cells(Cikl, Valószín)).Value _
= Range(Cells(Cikl - 1, Előford + 1), Cells(Cikl - 1, Valószín)).Value
For j = 1 To 90
Cells(8, Előford + j) = Cells(8, Előford + j) + 1 'n(i) cellasor munkatáblában(i) cellasor
Next j
If Cells(Cikl, 4) Then
For j = 1 To 5
Cells(Cikl, Előford + Cells(Cikl, 3 + j)) _
= Cells(Cikl, Előford + Cells(Cikl, 3 + j)) + 1
Cells(8, Előford + Cells(Cikl, 3 + j)) = 0 'n(i) cellasor
Next j
End If
'Calculate
Range(Cells(Cikl, Valószín + 1), Cells(Cikl, Várak)).Value _
= Range(Cells(12, Előford + 1), Cells(12, Valószín)).Value
Range(Cells(Cikl, Várak + 1), Cells(Cikl, Várak + 90)).Value _
= Range(Cells(8, Előford + 1), Cells(8, Valószín)).Value
Next Cikl
Call CountCcolor 'Prohardver nyomám Színes cellák számolása**** Modul3 lapon
Poisson2 = WorksheetFunction.Sum(Range("O14:S14")) 'Solver Célcella
Call kep_be
End Function

• #45398 Fferi50 Topikgazda KBaj #45397

  Új Válasz 2020-11-20 21:36:03 #45398

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Fferi50

  Topikgazda

  válasz KBaj #45397 üzenetére

  Szia!
  Mutatom a </> gombot:
  
  És az eredménye:
  Function Poisson2(Feltétel2 As Range) As Long
Call kep_ki
Application.Volatile ’Prohardver Delila_1 nyomán
k = 0
Kezd = Cells(8, 7) 'Feltétel kezdete oszlop
Kezd5 = Kezd + 5 'Javasolt számok terület előtti oszlop száma
Kezd22 = Kezd + 22 'Feltételek a javaslat válogatásához
a = Cells(12, Kezd) 'A munkatábla kezdő előtti oszlop száma
Előford = Kezd + a 'K(i) táblázat kezdő előtti oszlop száma
Valószín = Előford + 90 'P(x=1) táblázat kezdő előtti oszlop száma
Várak = Valószín + 90 'n(i) táblázat kezdő előtti oszlop száma
Us = Cells(4, 7) + Cells(2, 7) 'Táblázat utolsó sora
Cikl = Cells(5, Előford + 1) 'A számolás kezdete sor
Cells(6, Előford + 1) = Cikl 'Ez lesz a Ciklusváltozó kezdete
Range(Cells(Cikl + 1, Kezd + 1), Cells(Us, Kezd + 15)).ClearContents 'számítása sorok törlése
Range(Cells(Cikl, Előford + 1), Cells(Us, Valószín)).ClearContents 'K(i) táblázat törlése
Range(Cells(8, Előford + 1), Cells(8, Valószín)).Value = _
Range(Cells(Cikl - 1, Várak + 1), Cells(Cikl - 1, Várak + 90)).Value 'Az n(i-1) sor feltöltése
Cells(14, Előford + 1).Formula = Cells(14, Kezd + 49).Formula
Cells(14, Előford + 1).Select 'Kijelölés kitöltéshez
Selection.AutoFill Destination:=Range(Cells(14, Előford + 1), Cells(14, Valószín)), Type:=xlFillDefault
'Feltételek
Range("AF11:AJ11").Value = Range("AF4:AJ4").Value 'Manuális számítás
'Calculate 'A munkalapfüggvények számolása
For Cikl = Cells(6, Előford + 1) To Us 'Az utolsó + 1-ig
'1. : 'Az n(i-1) és az előző ciklusban kitörölt képletek újrafelépítése a Tartalék raktárcellából BF14
Range(Cells(8, Előford + 1), Cells(8, Valószín)).Value = _
Range(Cells(Cikl - 1, Várak + 1), Cells(Cikl - 1, Várak + 90)).Value 'Az n(i-1) sor feltöltése
Cells(14, Előford + 1).Formula = Cells(14, Kezd + 49).Formula 'Képlet
Cells(14, Előford + 1).Select 'Kijelölés kitöltéshez
Selection.AutoFill Destination:=Range(Cells(14, Előford + 1), Cells(14, Valószín)), Type:=xlFillDefault
'[P(x=1) 13-dik sor]
For i = 1 To 5
For j = 1 To 90
Calculate 'A munkalapfüggvények kiszámolják a 14-dik
If Cells(13, Előford + j) <= Cells(11, Kezd22 + i) _
And Cells(14, Előford + j) Then
For k = 1 To 5
If Cells(14, Előford + j) = Cells(Cikl, Kezd5 + k) Then GoTo Köv
Next k
Cells(Cikl, Kezd5 + Cells(17, Kezd5 + i)) = Cells(14, Előford + j)
Cells(Cikl, Kezd + 10 + Cells(17, Kezd5 + i)) = Cells(13, Előford + j)
Cells(14, Előford + j) = ""
j = 90
End If
Köv: Next j
Next i
'2.
Cells(6, Előford + 1) = Cikl
'Calculate 'A munkalapfüggvények számolása
If Cells(Cikl, 4) Then
For j = 1 To 5
Cells(Cikl, Kezd + j) = Cells(12, Előford + Cells(Cikl, 3 + j))
Next j
Else
End If
'Calculate 'A munkalapfüggvények számolása
Range(Cells(Cikl, Előford + 1), Cells(Cikl, Valószín)).Value _
= Range(Cells(Cikl - 1, Előford + 1), Cells(Cikl - 1, Valószín)).Value
For j = 1 To 90
Cells(8, Előford + j) = Cells(8, Előford + j) + 1 'n(i) cellasor munkatáblában(i) cellasor
Next j
If Cells(Cikl, 4) Then
For j = 1 To 5
Cells(Cikl, Előford + Cells(Cikl, 3 + j)) _
= Cells(Cikl, Előford + Cells(Cikl, 3 + j)) + 1
Cells(8, Előford + Cells(Cikl, 3 + j)) = 0 'n(i) cellasor
Next j
End If
'Calculate
Range(Cells(Cikl, Valószín + 1), Cells(Cikl, Várak)).Value _
= Range(Cells(12, Előford + 1), Cells(12, Valószín)).Value
Range(Cells(Cikl, Várak + 1), Cells(Cikl, Várak + 90)).Value _
= Range(Cells(8, Előford + 1), Cells(8, Valószín)).Value
Next Cikl
Call CountCcolor 'Prohardver nyomám Színes cellák számolása**** Modul3 lapon
Poisson2 = WorksheetFunction.Sum(Range("O14:S14")) 'Solver Célcella
Call kep_be
End Function
  Amint látod, sokkal olvashatóbb.
  Érdekes lenne még az a munkalap, amin futtatod ezt a makrót. Legalább egy kép a használt területről.
  Üdv.

• #45397 KBaj kezdő Fferi50 #45396

  Új Válasz 2020-11-20 20:52:13 #45397

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  KBaj

  kezdő

  válasz Fferi50 #45396 üzenetére

  Kedves Fferi50 !
  Ime a program, elég hosszú. Persze ez is függvény azért, mert ha fog működni SOLVER célcellájaként akarom alkalmazni.
  Function Poisson2(Feltétel2 As Range) As Long
  Call kep_ki
  Application.Volatile ’Prohardver Delila_1 nyomán
  k = 0
  Kezd = Cells(8, 7) 'Feltétel kezdete oszlop
  Kezd5 = Kezd + 5 'Javasolt számok terület előtti oszlop száma
  Kezd22 = Kezd + 22 'Feltételek a javaslat válogatásához
  a = Cells(12, Kezd) 'A munkatábla kezdő előtti oszlop száma
  Előford = Kezd + a 'K(i) táblázat kezdő előtti oszlop száma
  Valószín = Előford + 90 'P(x=1) táblázat kezdő előtti oszlop száma
  Várak = Valószín + 90 'n(i) táblázat kezdő előtti oszlop száma
  Us = Cells(4, 7) + Cells(2, 7) 'Táblázat utolsó sora
  Cikl = Cells(5, Előford + 1) 'A számolás kezdete sor
  Cells(6, Előford + 1) = Cikl 'Ez lesz a Ciklusváltozó kezdete
  Range(Cells(Cikl + 1, Kezd + 1), Cells(Us, Kezd + 15)).ClearContents 'számítása sorok törlése
  Range(Cells(Cikl, Előford + 1), Cells(Us, Valószín)).ClearContents 'K(i) táblázat törlése
  Range(Cells(8, Előford + 1), Cells(8, Valószín)).Value = _
  Range(Cells(Cikl - 1, Várak + 1), Cells(Cikl - 1, Várak + 90)).Value 'Az n(i-1) sor feltöltése
  Cells(14, Előford + 1).Formula = Cells(14, Kezd + 49).Formula
  Cells(14, Előford + 1).Select 'Kijelölés kitöltéshez
  Selection.AutoFill Destination:=Range(Cells(14, Előford + 1), Cells(14, Valószín)), Type:=xlFillDefault
  'Feltételek
  Range("AF11:AJ11").Value = Range("AF4:AJ4").Value 'Manuális számítás
  'Calculate 'A munkalapfüggvények számolása
  For Cikl = Cells(6, Előford + 1) To Us 'Az utolsó + 1-ig
  '1. : 'Az n(i-1) és az előző ciklusban kitörölt képletek újrafelépítése a Tartalék raktárcellából BF14
  Range(Cells(8, Előford + 1), Cells(8, Valószín)).Value = _
  Range(Cells(Cikl - 1, Várak + 1), Cells(Cikl - 1, Várak + 90)).Value 'Az n(i-1) sor feltöltése
  Cells(14, Előford + 1).Formula = Cells(14, Kezd + 49).Formula 'Képlet
  Cells(14, Előford + 1).Select 'Kijelölés kitöltéshez
  Selection.AutoFill Destination:=Range(Cells(14, Előford + 1), Cells(14, Valószín)), Type:=xlFillDefault
  '[P(x=1) 13-dik sor]
  For i = 1 To 5
  For j = 1 To 90
  Calculate 'A munkalapfüggvények kiszámolják a 14-dik
  If Cells(13, Előford + j) <= Cells(11, Kezd22 + i) _
  And Cells(14, Előford + j) Then
  For k = 1 To 5
  If Cells(14, Előford + j) = Cells(Cikl, Kezd5 + k) Then GoTo Köv
  Next k
  Cells(Cikl, Kezd5 + Cells(17, Kezd5 + i)) = Cells(14, Előford + j)
  Cells(Cikl, Kezd + 10 + Cells(17, Kezd5 + i)) = Cells(13, Előford + j)
  Cells(14, Előford + j) = ""
  j = 90
  End If
  Köv: Next j
  Next i
  '2.
  Cells(6, Előford + 1) = Cikl
  'Calculate 'A munkalapfüggvények számolása
  If Cells(Cikl, 4) Then
  For j = 1 To 5
  Cells(Cikl, Kezd + j) = Cells(12, Előford + Cells(Cikl, 3 + j))
  Next j
  Else
  End If
  'Calculate 'A munkalapfüggvények számolása
  Range(Cells(Cikl, Előford + 1), Cells(Cikl, Valószín)).Value _
  = Range(Cells(Cikl - 1, Előford + 1), Cells(Cikl - 1, Valószín)).Value
  For j = 1 To 90
  Cells(8, Előford + j) = Cells(8, Előford + j) + 1 'n(i) cellasor munkatáblában(i) cellasor
  Next j
  If Cells(Cikl, 4) Then
  For j = 1 To 5
  Cells(Cikl, Előford + Cells(Cikl, 3 + j)) _
  = Cells(Cikl, Előford + Cells(Cikl, 3 + j)) + 1
  Cells(8, Előford + Cells(Cikl, 3 + j)) = 0 'n(i) cellasor
  Next j
  End If
  'Calculate
  Range(Cells(Cikl, Valószín + 1), Cells(Cikl, Várak)).Value _
  = Range(Cells(12, Előford + 1), Cells(12, Valószín)).Value
  Range(Cells(Cikl, Várak + 1), Cells(Cikl, Várak + 90)).Value _
  = Range(Cells(8, Előford + 1), Cells(8, Valószín)).Value
  Next Cikl
  Call CountCcolor 'Prohardver nyomám Színes cellák számolása**** Modul3 lapon
  Poisson2 = WorksheetFunction.Sum(Range("O14:S14")) 'Solver Célcella
  Call kep_be
  End Function
  
  Elég hosszú a program, van még mit csiszolni, egyszerűsíteni rajta. Mint már említettem kezdő programozó vagyok, nem értem a (</>) gombot mit jelent.
  Segítségedet előre is köszönöm.
  Üdvözlettel:
  KBaj

• #45199 Delila_1 veterán zsolti_20 #45192

  Új Válasz 2020-10-31 11:43:11 #45199

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Delila_1

  veterán

  válasz zsolti_20 #45192 üzenetére

  Nem volt egyszerű, de végül sikerült.

  Sub Eredmeny()
Dim sorSzuro As Integer, sorEredm As Integer, db As Integer, csoport As Integer
Dim usorLista, x As Integer, elso As Integer, ucso As Integer, nev As String, van

sorEredm = 2: csoport = 1
usorLista = Range("D" & Rows.Count).End(xlUp).Row

Kezd:
elso = Application.Match(csoport, Columns(1), 0)
ucso = Application.Match(csoport, Columns(1))
db = 0
For x = elso To ucso
If Application.WorksheetFunction.CountIf(Columns(4), Cells(x, 2)) > 0 Then db = db + 1
If db = ucso - elso + 1 Then
For sorSzuro = 2 To usorLista
nev = Cells(sorSzuro, "D")
On Error Resume Next
van = Application.Match(nev, Range(Cells(elso, "B"), Cells(ucso, "B")), 0)
If VarType(van) = vbError Then
On Error GoTo 0
Else
Cells(sorEredm, "F") = csoport
Cells(sorEredm, "G") = nev
sorEredm = sorEredm + 1
End If
Next
End If
Next
csoport = csoport + 1
If csoport > Application.WorksheetFunction.Max(Columns(1)) Then
Exit Sub
Else
GoTo Kezd
End If
End Sub

• #45187 Pakliman tag Norbika1493 #45186

  Új Válasz 2020-10-30 07:51:37 #45187

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Pakliman

  tag

  válasz Norbika1493 #45186 üzenetére

  Egy pl...
  Ez egy meglévő táblázatban halad végig és bizonyos cellák értéke alapján színez bizonyos számokat is.
  Készít egy táblázatot az így létrejótt listából és elküldi a megadott címzetteknek:

  Public Enum OlBodyFormat
olFormatUnspecified = 0
olFormatPlain = 1
olFormatHTML = 2
olFormatRichText = 3
End Enum

Private Function TableDataColor(strIn As String, Optional color As String = "") As String
If color = "" Then
TableDataColor = strIn
Else
TableDataColor = "<FONT COLOR=" & color & ">" & strIn & "</FONT>"
End If
End Function

Private Function Table(strIn As String, Optional lBorder As Long = 0) As String
Dim sBorder As String

If lBorder = 0 Then
sBorder = ""
Else
sBorder = " border=" & lBorder
End If

Table = "<TABLE" & sBorder & ">" & strIn & "</TABLE>"
End Function

Private Function TableData(strIn As String, Optional alignment As String = "") As String
TableData = "<TD nowrap align=" & alignment & ">" & strIn & "</TD>"
End Function

Private Function TableRow(strIn As String) As String
TableRow = "<TR>" & strIn & "</TR>"
End Function

Public Sub Email_Humányügyre()
Dim sSzöveg1 As String: sSzöveg1 = "Kedves Lányok!" & "<br /><br />"
Dim sSzöveg2 As String: sSzöveg2 = "Szíves hasznosításra..." & "<br /><br />" & _
"Üdv," & "<br /><br />"

Dim OutApp As Object
Dim OutMail As Object

Dim strFej As String
Dim strTB As String

Dim sDátum As String: sDátum = Format(Format(Range("Z1"), "0000"".""00"".""00"), "yyyy. mmmm")
Dim sTárgy As String: sTárgy = "Külsősök teljesítései " & sDátum
Dim lAktSor As Long
Dim lÚjSor As Long
Dim szín As String

strFej = TableRow( _
TableData("HR") & _
TableData("Név") & _
TableData("Összes óra") _
)

For lAktSor = 3 To Cells.Rows.Count 'Az utolsó sort célszerű először meghatározni...
If IsEmpty(Cells(lAktSor, 1)) Then Exit For
If Cells(lAktSor, 15) = "Külsős" Then
Select Case Cells(lAktSor, 11)
Case 60 To 79.9
szín = "blue"

Case Is > 80
szín = "red"

Case Else
szín = ""
End Select
strTB = strTB & _
TableRow( _
TableData(Cells(lAktSor, 1)) & _
TableData(Cells(lAktSor, 2)) & _
TableData( _
TableDataColor( _
Format(Cells(lAktSor, 11), "0.0"), _
szín _
), _
"right" _
) _
)
End If
Next lAktSor

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
.To = "Humánügyek"
.CC = "hum1@hum.hu; hum2@hum.hu"
.BCC = ""
.Subject = sTárgy
.BodyFormat = 2 'olFormatHTML
.HTMLBody = sSzöveg1 & _
Table( _
"<Caption>Külsős órák</Caption>" & _
strFej & _
strTB _
, 1) & "<br /><br />" & _
sSzöveg2

.Display ' vagy elküldéshez .Send
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing
End Sub

• #45063 lappy őstag andreas49 #45062

  Új Válasz 2020-10-06 07:13:44 #45063

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  lappy

  őstag

  válasz andreas49 #45062 üzenetére

  Itt van egy ilyen kód amire szükséged van
  Sub InsertRowsAtCursor()
    Answer = InputBox("How many Rows to insert? (50 Rows maximum)")
    NumLines = Int(Val(Answer))
    If NumLines > 50 Then
        NumLines = 50
    End If
    If NumLines = 0 Then
        GoTo EndInsertLines
    End If
    Do
        Selection.EntireRow.Insert
        Count = Count + 1
    Loop While Count < NumLines
EndInsertLines:
End Sub

• #44759 Mutt senior tag Telda #44739

  Új Válasz 2020-09-02 21:09:03 #44759

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Mutt

  senior tag

  válasz Telda #44739 üzenetére

  Szia,

  Nincs CS01 hozzáférésem, így nem tudtam tesztelni de ezt próbáld meg:

  Dim objExcel
Dim objSheet, intRow, i
Set objExcel = GetObject(, "Excel.Application")
Set objSheet = objExcel.Workbooks("dj feltolt").Sheets("Munka1")

For i = 2 To objSheet.UsedRange.Rows.Count
COL1 = Trim(CStr(objSheet.Cells(i, 1).Value)) 'Column1

'CS01 fõképernyõn anyagszám / plant / BOM usage megadása
session.findById("wnd[0]/usr/ctxtRC29N-MATNR").Text = COL1
'session.findById("wnd[0]/usr/ctxtRC29N-WERKS").text = "0610"
session.findById("wnd[0]/usr/ctxtRC29N-STLAN").Text = "1"
session.findById("wnd[0]/usr/txtRC29N-WTEXT").SetFocus
session.findById("wnd[0]/usr/txtRC29N-WTEXT").caretPosition = 0
session.findById("wnd[0]").sendVKey 0
session.findById("wnd[0]").sendVKey 0

'component screen amiről csak akkor kell elmenni, ha másik anyagot kell felépíteni
j = -1
Do
j = j + 1
COL2 = Trim(CStr(objSheet.Cells(i + j, 2).Value)) 'Column2
COL3 = Trim(CStr(objSheet.Cells(i + j, 3).Value)) 'Column3
session.findById("wnd[0]/usr/tabsTS_ITOV/tabpTCMA/ssubSUBPAGE:SAPLCSDI:0152/tblSAPLCSDITCMAT/ctxtRC29P-POSTP[1," & CStr(j) & "]").Text = "L"
session.findById("wnd[0]/usr/tabsTS_ITOV/tabpTCMA/ssubSUBPAGE:SAPLCSDI:0152/tblSAPLCSDITCMAT/ctxtRC29P-IDNRK[2," & CStr(j) & "]").Text = COL2
session.findById("wnd[0]/usr/tabsTS_ITOV/tabpTCMA/ssubSUBPAGE:SAPLCSDI:0152/tblSAPLCSDITCMAT/txtRC29P-MENGE[5," & CStr(j) & "]").Text = COL3
session.findById("wnd[0]/usr/tabsTS_ITOV/tabpTCMA/ssubSUBPAGE:SAPLCSDI:0152/tblSAPLCSDITCMAT/txtRC29P-MENGE[5," & CStr(j) & "]").SetFocus
session.findById("wnd[0]/usr/tabsTS_ITOV/tabpTCMA/ssubSUBPAGE:SAPLCSDI:0152/tblSAPLCSDITCMAT/txtRC29P-MENGE[5," & CStr(j) & "]").caretPosition = 5
session.findById("wnd[0]").sendVKey 0
session.findById("wnd[0]").sendVKey 0
Loop Until COL1 <> Trim(CStr(objSheet.Cells(i + j + 1, 1).Value))

'mentés
session.findById("wnd[0]/tbar[0]/btn[11]").press

'léptetni kell az i értékét
i = i + j
Next i
MsgBox "Keszen vagyunk"

  Neked egy fájlban vannak a létrehozandó anyagtörzsek (az aktuális mindig a COL1 változóban van), így addig nem kell kilépned CS01-ből amíg új anyaghoz nem érsz.
  A fenti megoldásban van egy Do - Loop ciklus ami addig adogatja a komponenseket a listához amíg a COL1 értéke meg nem változik.

  A másik fontos dolog, hogy a rácson hivatkozni SAP-ban sor és oszlop azonosítóval lehet.
  pl. .. CMAT/ctxtRC29P-IDNRK[2,0] mindig a második mezőt az első soron jelenti, vagyis a komponenst.
  A sor változót kell léptetni, hogy a komponensek egymás alá kerüljenek és ne mindig az első sor legyen felülírva. Ezért van mindegyik sorban a j belső változó meghívva.

  Ami fontos, hogy a script el fog hasalni ha olyan sorra hivatkozol ami a nem látható képernyő része. A képernyőmentéseden látszik 19 sor, de ha kisebbre teszed a GUI-t akkor lehet hogy csak 5 sort fogsz látni. Ezt kivédeni úgy lehet, hogy mielőtt írnál megnézed hogy létezik-e az adott sor. Tippre vhogy így:
  On Error Resume Next
If session.findById("wnd[0]/usr/tabsTS_ITOV/tabpTCMA/ssubSUBPAGE:SAPLCSDI:0152/tblSAPLCSDITCMAT/ctxtRC29P-POSNR[0," & CStr(j) & "]").Text <> Right("000" & j, 4) Then
MsgBox "hiba"
End If
On Error GoTo 0

  Megkértem a jogosultságot a CS01-hez így ha majd megkapom akkor tudom tesztelni, hogy az elmélet párosul-e a valósággal.

  üdv

• #44754 DeFranco nagyúr

  Új Válasz 2020-09-02 17:14:43 #44754

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  DeFranco

  nagyúr

  Sziasztok,

  írogattam már VBA kódokat, túl sok szakmai alapom nincs hozzá, de általában összekalapálok egész használható dolgokat ami megkönnyíti a munkámat, viszont előfordul hogy az alapok hiánya miatt megáll a tudomány egy egyszerű lépésnél, ez van most is.

  Azt szeretném automatizálni hogy ha kiválasztok egy tartományt, akkor a kód lépkedjen végig a kiválasztott tartomány egyes celláin és hajtsa végre a következő műveleteket:
  0: kiválasztom az A1:D4 tartományt
  1: nézze meg a soron következő cella (pl. A1) értékét
  A1 cella tartalma: rántotta),
  azt írja be magának egy változóba
  2: ugyanebbe a cellába (A1) írjon be egy előre definiált képletet (legyen mondjuk =BAL([A1];2) ) ahol az [A1] paraméter értéke értelemszerűen az A1 cellából felírt érték:
  eredmény (A1 cella tartalma) =BAL("rántotta";2)
  3: fogja meg az A1 cellát és a tartalmát mentse értékre:
  eredmény (A1 cella tartalma) rá
  4: lépjen a kiválasztásban a soron következő cellára
  5: GOTO 1

  tegye ezt addig amíg a kijelölés végére nem ér (D4)

  gondolom ez egy FOR ciklus lesz, ami nehézséget okoz, hogy hogyan olvasom ki a kijelölés paramétereit, tehát a kijelölt terület első cellája, sorok és oszlopok száma, amit a ciklus paramétereinek beadok. a többi elvileg menne.

• #44567 bucihost senior tag

  Új Válasz 2020-07-30 14:39:36 #44567

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  bucihost

  senior tag

  Sziasztok!

  Találtam egy kódot, amit ökéletesen működik. Viszont, néha az oldal "hibát dob" ahonnan a képeket kérném le mert gondolom egyszerre sok a lekérdezést.

  Hogyan lehetne késlelteni a lekérdezért, hogy 1-1- kép között várjon mondjuk 2-3 másodpercet?

  Sub URLPictureInsert()
Dim Pshp As Shape
Dim xRg As Range
Dim xCol As Long
On Error Resume Next
Application.ScreenUpdating = False
Set rng = ActiveSheet.Range("C2:C90")
For Each cell In rng
filenam = cell
ActiveSheet.Pictures.Insert(filenam).Select
Set Pshp = Selection.ShapeRange.Item(1)
If Pshp Is Nothing Then GoTo lab
xCol = cell.Column + 1
Set xRg = Cells(cell.Row, xCol)
With Pshp
.LockAspectRatio = msoFalse
If .Width > xRg.Width Then .Width = xRg.Width * 2 / 3
If .Height > xRg.Height Then .Height = xRg.Height * 2 / 3
.Top = xRg.Top + (xRg.Height - .Height) / 2
.Left = xRg.Left + (xRg.Width - .Width) / 2
End With
lab:
Set Pshp = Nothing
Range("A2").Select
Next
Application.ScreenUpdating = True
End Sub


• #44234 Mutt senior tag Mutt #44232

  Új Válasz 2020-06-10 12:29:00 #44234

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Mutt

  senior tag

  válasz Mutt #44232 üzenetére

  Annyi pontosítás, hogy ahogy nézem a sort könnyebben el lehet érni, vagyis a a kód rövidebb tud lenni.

  illetve annyit finomítottam, hogy csak akkor frissít ha a linkedcell értéke nem jó.

  Sub UpdateLinkedCells()
Dim sp As Shape
Dim rng As Range

Const sorEltol As Long = 0
Const oszlopEltol As Long = 7

For Each sp In ActiveSheet.Shapes
'az aktív lapon talált objektumok közül csak a jelölőnégyzeteket keressük meg
'hiba esetén menjünk tovább
On Error Resume Next
If sp.DrawingObject.progID Like "*CheckBox*" Then

'a jelőlőnégyzet a TopLeftCell.Column oszlopban található, a sort pedig TopLeftCell.Row adja meg
'a sor és oszlop azonosítókat csal akkor toljuk el a megadott értékkel ha ráférnek még a lapra
If sp.TopLeftCell.Row + sorEltol <= Rows.Count And sp.TopLeftCell.Column + oszlopEltol <= Columns.Count Then
Set rng = Cells(sp.TopLeftCell.Row + sorEltol, sp.TopLeftCell.Column + oszlopEltol)

'frissítsünk ha az új hely máshol van
If Intersect(rng, ActiveSheet.Range(sp.DrawingObject.LinkedCell)) Is Nothing Then
'mentsük át az új helyre az eddigi értéket
rng = ActiveSheet.Range(sp.DrawingObject.LinkedCell)

'töröljük a korábbi hely tartalmát
ActiveSheet.Range(sp.DrawingObject.LinkedCell).ClearContents

'linkeljük be az újat
sp.DrawingObject.LinkedCell = rng.Address
End If
End If
End If
On Error GoTo 0

Next sp

End Sub

• #44126 szricsi_0917 tag Mutt #44122

  Új Válasz 2020-05-26 17:38:58 #44126

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  szricsi_0917

  tag

  válasz Mutt #44122 üzenetére

  Szia

  Sub kmfrissites_auto()
Dim auto As Worksheet
Dim utnyilvan As Worksheet
Dim szerviz As Worksheet
Dim lastrow
Dim lastrow1
Dim lastrow2
Dim i As Long
Dim a As Long
Dim vMax As Double
Dim xMax As Double
'On Error GoTo kmfrissites_auto_Error
Set auto = Sheets("Autó")
Set utnyilvan = Sheets("Útnyilvántartó")
Set szerviz = Sheets("Szerviznyilvántartó")
lastrow = auto.Cells(Rows.Count, 1).End(xlUp).Row
lastrow1 = utnyilvan.Cells(Rows.Count, 1).End(xlUp).Row
lastrow2 = szerviz.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
For a = 10 To 21  
  auto.Range("V" & i) = Evaluate("=SumProduct(Max((Szerviznyilvántartó!B2:B" & lastrow2 & " = Autó!B" & i & ") * (INDIRECT(""'Szerviznyilvántartó'!"" & address(2," & a & ",4) & "":"" & INDIRECT(address(" & lastrow2 & "," & a & ",4)) = ""Motorolajcsere"") * Szerviznyilvántartó!G2:G" & lastrow2 & "))")

  Átalakítottam az általad javasolt megoldásra viszont újabb probléma merült fel.
  Több feltételt szeretnék hozzárakni. A probléma, hogy a 2. feltétel más méretű tömb mint a többi így ugye hibára fut a képlet.
  For ciklussal oldottam meg, hogy a 2. feltételnél oszloponként megy újra végig és mindig az utolsó legnagyobb értéket hagyja meg így a végén megkapom majd a maximum értéket.
  A probléma, hogy az indirect megoldással mindig érték hibára fut. Mi lehet a probléma?

• #44062 Mutt senior tag mulli86 #44058

  Új Válasz 2020-05-20 09:43:50 #44062

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Mutt

  senior tag

  válasz mulli86 #44058 üzenetére

  Szia,

  1. lastsor típusa Long legyen, mert az integer csak 32 ezer sorral fog bírni.
  2. A hibaname és oszlopnumber a két for cikluson belül van inicilaziálva ami nem jó, hozd ki őket a for-ok elé.
  3. Variant a hibaname típusa, de közben a cella értékét ellenőrzöd. Jobb lenne egy specifikus típust használnod pl. Double ha számok érdekelnek, vagy String ha szöveg.
  4. Ha sokat dolgozol egy lapon akkor érdemes With ... End With-et használnod.
  pl.
  With Worksheets(1)
lastsor = .Range("A5").End(xlDown).Row

For x ...
For y ...
hibaname = .Cells(5, y)

For p ...
If hibaname = Sheets(3).Cells(1,p) then
....
End If
Next p
Next y
Next x

End With

  5. A GoTo rész biztos hogy kell? Miért nem teszed az IF-be az ottani dolgokat?
  6. Sokat gyorsít a "villódzás" kikapcsolása.
  Application.ScreenUpdating = False a for ciklusok elé, majd = True a legvégén.

  üdv

• #43324 Fferi50 Topikgazda ROBOTER #43323

  Új Válasz 2020-03-21 17:02:56 #43324

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Fferi50

  Topikgazda

  válasz ROBOTER #43323 üzenetére

  Szia!
  A nevek mindaddig megmaradnak a munkafüzetben, amíg ki nem törölted azokat - mindegy, hogy a munkafüzetben kézzel vagy makróval hoztad létre azokat. Tehát ismételt megnyitás esetén nem is kell már foglalkozni velük, hacsak nem módosítani szükséges.
  Ha nem létezik a név, a Subscript out of Range (9 -es hibaszám) hibaüzenet adja tudtul.
  On Error Resume Next 
nev=names("neve").name
if Err=9 Then  ' a név még nincs létrehozva
    létrehozod a nevet
endif
Err=0
On Error Goto 0

  Üdv.

• #43244 Delila_1 veterán ny.erno #43238

  Új Válasz 2020-03-13 12:11:40 #43244

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  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 Sub

  Szerk.: a termékek számát bővítheted, vagy szűkítheted.

• #43112 zsolti_20 senior tag Delila_1 #43111

  Új Válasz 2020-02-23 15:40:48 #43112

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  zsolti_20

  senior tag

  válasz Delila_1 #43111 üzenetére

  Bedobom ide a teljes kódot, így lesz a legjobb. Kicsi alakítottam rajta, de sajnos mindig errort kapok pont ott ahol el kellene kezdenie átmásolni.
  
  Function getFile() As Workbook
 Dim fn As Variant
 
 fn = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*", Title:="Select workbook")
 If TypeName(fn) <> "Boolean" Then Set getFile = Workbooks.Open(fn)
End Function
Sub useGetFile()
Dim Dic As Object, key As Variant, oCell As Range, i&
 Dim wb1 As Workbook, wb2 As Workbook
 Dim wb1Sheet1 As Worksheet, wb2Sheet1 As Worksheet
 
 Set wb2 = getFile
 If Not wb2 Is Nothing Then
 On Error Resume Next
 Set wb2Sheet1 = wb2.Sheets("Sheet1")
 On Error GoTo 0
 If Not wb2Sheet1 Is Nothing Then
 Set wb1 = Workbooks("1.xlsx")
 Set wb1Sheet1 = wb1.Sheets("Sheet1")
 i = wb1.Cells.SpecialCells(xlCellTypeLastCell).Row
 For Each oCell In wb1.Range("A1:A" & i)
 If Not Dic.exists(oCell.Value) Then
 Dic.Add oCell.Value, oCell.Offset(, 3).Value
 End If
 Next
 i = wb2.Cells.SpecialCells(xlCellTypeLastCell).Row
 For Each oCell In wb2.Range("A2:A" & i)
 For Each key In Dic
 If oCell.Value = key Then
 oCell.Offset(, 2).Value = Dic(key)
 End If
 Next
 Next
 
 
 Else
 MsgBox "Sheet1 not found in " & wb2.Name, vbCritical
 End If
 'Maybe close wb2 here?
 wb2.Close SaveChanges:=False
 Else
 Debug.Print "User cancelled"
 End If
 Set wb1 = Nothing
 Set wb2 = Nothing
 Set wb1Sheet1 = Nothing
 Set wb2Sheet1 = Nothing
End Sub


• #43107 zsolti_20 senior tag Delila_1 #43106

  Új Válasz 2020-02-22 19:22:06 #43107

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  zsolti_20

  senior tag

  válasz Delila_1 #43106 üzenetére

  Ígérem mára az utolsó kérdés Van két excel fileom, az elsőben az A oszlopban lefelé vannak számok felsorolva, amik mellett a B oszlopban adat van megadva Pl 1 | a 2 | b stb...
  Itt van jó pár száz sor. A másik excel fileban van a több száz szám közül néhány, van amikor 5 de van amikor 20. Szeretném ezeket a számokat megkeresni az első excel fileban, és a megfelelő szám mellé a megfelelő értéket átmásolni, hogy ne nekem kelljen egyesével kikeresgélni.

  Sub VlookMultipleWorkbooks()
    Dim lookFor As Range
    Dim srchRange As Range
    Dim book1 As Workbook
    Dim book2 As Workbook
    Dim book2Name As String
    book2Name = "1.xlsx"    'modify it as per your requirement
    Dim book2NamePath As String
    book2NamePath = ThisWorkbook.Path & "\" & book2Name
    Set book1 = ThisWorkbook
    If IsOpen(book2Name) = False Then Workbooks.Open (book2NamePath)
    Set book2 = Workbooks(book2Name)
    Set lookFor = book1.Sheets(1).Cells(5, 1)   ' value to find
    Set srchRange = book2.Sheets(1).Range("A:B")    'source
    lookFor.Offset(0, 1).Value = Application.VLookup(lookFor, srchRange, 2, False)
End Sub
Function IsOpen(strWkbNm As String) As Boolean
    On Error Resume Next
    Dim wBook As Workbook
    Set wBook = Workbooks(strWkbNm)
    If wBook Is Nothing Then    'Not open
        IsOpen = False
        Set wBook = Nothing
        On Error GoTo 0
    Else
        IsOpen = True
        Set wBook = Nothing
        On Error GoTo 0
    End If
End Function

  Ez a kód egész jó lenne, de a probléma az, hogy abba a sorba akarja beilleszteni az értéket ahonnan kimásolta előtte, de az adott szám nem a 68-ik sorban van hanem mondjuk a harmadikban.
  
  A másik probléma hogy csak egy értéket másol át de én az összeset szeretném egyszerre.

• #42880 Fferi50 Topikgazda Sesy #42877

  Új Válasz 2020-01-28 08:12:19 #42880

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Fferi50

  Topikgazda

  válasz Sesy #42877 üzenetére

  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 Worksheet
Set sh = ActiveSheet
Set tabla = Range("X1:Y100") 'itt van a kulcstábla
On Error Resume Next
For Each cl In sh.UsedRange.Columns(1).Offset(1, 0).Cells 'az első oszlopon a 2. cellától megy végig
    If cl.Value = "" Then Exit For 'üres cella esetén kilép a ciklusból
    klcs = Left(cl.Value, 2) ' az első két karakter a kulcs
    mlapnev = tabla.Find(what:=klcs, LookIn:=xlValues, lookat:=xlWhole).Offset(0, 1).Value
    If Err = 0 Then ' ha megtaláltuk az értéket a kulcstáblában, akkor
        Set sh1 = Sheets(mlapnev)
        If Err = 9 Then ' ha még nincs ilyen nevű munkalap
            Sheets("Sablon").Copy after:=Sheets(Sheets.Count) ' a Sablon nevű munkalapot másoljuk
            Set sh1 = Sheets(Sheets.Count) ' és átnevezzük
            sh1.Name = mlapnev
            Err = 0
        End If
        sh1.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ét
     Else ' figyelmeztetés, hogy olyan kulcs van, amihez még nincs érték        MsgBox "Ehhez a kulcshoz nincs név: " & klcs, vbInformation
        Err = 0 ' ezt az értéket figyelmen kívül hagyja és megy tovább
     End If
Next
On Error GoTo 0
sh.Activate
MsgBox "kész vagyok", vbExclamation
End 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.

• #42431 sztanozs veterán szőröscica #42427

  Új Válasz 2019-12-10 10:08:34 #42431

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  sztanozs

  veterán

  válasz szőröscica #42427 üzenetére

  1) nem látom, hogy a boundary definiálva lenne
  2) nem xml adat amit átadsz (nem beszédes a változónév)
  3) nincsenek definiálva a változók
  Nem bonyolítod el ezt egy kicsit?

  Én így küldök GET/POST ützenetet:
  Public Function CMD_ServiceXML(ByRef Vars As Variant, Query As String, Optional Method As String = "GET") As Object
    Dim strResponse As String
    Dim objHTTP As Object
    Set objHTTP = CreateObject("Microsoft.XMLHTTP")
    
    If IsArray(Vars) Then
        Dim var, vx
        vx = 0
        For Each var In Vars
            Query = Replace(Query, "{" & vx & "}", URLEncode(CStr(var)))
            vx = vx + 1
        Next
    Else
        Query = Replace(Query, "{0}", UCase(Vars))
    End If
    
    If UCase(Method) = "GET" Then
        objHTTP.Open "GET", Query, False
        objHTTP.Send
    ElseIf UCase(Method) = "POST" Then
        Dim URI
        URI = Split(Query, "?")
        objHTTP.Open "GET", URI(0), False
        objHTTP.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        objHTTP.Send URI(1)
    Else
        Set CMD_ServiceXML = Nothing
    End If
    
    If objHTTP.statusText = "OK" Then
        strResponse = objHTTP.ResponseText
        Set objHTTP = Nothing
    Else
        Set CMD_ServiceXML = Nothing
        Set objHTTP = Nothing
        Exit Function
    End If
    
    Set CMD_ServiceXML = CreateObject("Msxml2.DOMDocument.3.0")     ''// Using MSXML 3.0
    
    On Error Resume Next
    CMD_ServiceXML.LoadXML strResponse
    If err Then
        Debug.Print "<CMD XML>", Vars, strResponse
        err.Clear
        Set CMD_ServiceXML = Nothing
    End If
    On Error GoTo 0
    
End Function

• #42225 Fferi50 Topikgazda Richard #42223

  Új Válasz 2019-11-18 20:10:17 #42225

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Fferi50

  Topikgazda

  válasz Richard #42223 üzenetére

  Szia!

  Ha van a szűrésnek eredménye, akkor csak a szűrt értékeket másolja a DataBodyRange.Copy.

  A DataBodyRange az a fejléc és összesítősor nélküli tartományt jelenti. Ha nincs a szűrésnek eredménye, akkor ennek nincs látható része, tehát a SpecialCells(xlCelltypeVisible) hibával tér vissza és ezt a hibaüzenetet az Application.DisplayAlert paranccsal sem tudod elnyomni, csak a megelőző On Error Resume Next utasítással ellenőrizheted, hogy hiba keletkezett-e .
  On Error Resume Next
ListObjects(1).DataBodyRange.SpecialCells(xlCellTypeVisible).Copy
If Err<>0 Then Msgbox "Nincs mit másolni"
On Error Goto 0

  Viszont így a teljes tartomány egyben marad, ezért a sima DataBodyRange.Copy másolja az egészet. (Lehet, hogy ez bug, mert ilyenkor hibát kellene logikusan adni, ezt igazából Redmond tudhatja, miért nem így van.)
  A szűrés eredményét a táblázat teljes tartományának vizsgálatával is tudod ellenőrizni.
  pl. így, ekkor nem kell hibakezelés bele:
  ListObjects(1).Range.SpecialCells(xlCellTypeVisible).Rows.Count
  Üdv.

• #42206 Delila_1 veterán Fferi50 #42205

  Új Válasz 2019-11-16 17:56:03 #42206

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Delila_1

  veterán

  válasz Fferi50 #42205 üzenetére

  Egy keveset módosítottam, mert X-et tett oda is, ahova nem kellett volna, no meg a kérdezőnek .png képei vannak.

      For Each Pic In Pics
        Pic.Offset(0, -1).Select
        On Error Resume Next
        ActiveSheet.Shapes.AddPicture Filename:=Path & Pic.Value & ".png", linktofile:=msoFalse, saveWithdocument:=msoTrue, Left:=Pic.Offset(0, -1).Left + 5, Top:=Pic.Top, Width:=50, Height:=60
        If Pic.Value = "" Or Err <> 0 Then
            Pic.Offset(0, -1).Value = "X"
            Pic.Offset(0, -1).Font.ColorIndex = 3
            On Error GoTo 0
        Else
            Pic.RowHeight = 60
        End If
    Next

• #42172 Delila_1 veterán bucihost #42170

  Új Válasz 2019-11-13 07:41:46 #42172

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Delila_1

  veterán

  válasz bucihost #42170 üzenetére

  Másik megoldás, hogy a "nagy piros x kép" ne növelje a fájl méretét.
  A két, csillagokkal jelölt sor a kép méretét határozza meg. A 0.4-et írd át kedved szerint. Ki is hagyható ez a két sor.

  Sub PlacePics()
    Dim Path As String, Pics As Range, Pic As Range
    
  Path = "C:\Users\branyiczkif\Desktop\AjanlatKepek\kepek\"
  Set Pics = ActiveSheet.Range("B2:B20")
    
    For Each Pic In Pics
        Pic.Offset(0, -1).Select
        On Error Resume Next
      ActiveSheet.Pictures.Insert(Path & Pic.Value & ".png").Select
        Selection.ShapeRange.ScaleWidth 0.4, msoFalse, msoScaleFromTopLeft  '***
        Selection.ShapeRange.ScaleHeight 0.4, msoFalse, msoScaleFromTopLeft  '***
        If VarType(Selection.ShapeRange) = vbError Then
            Pic.Offset(0, -1).Value = "X"
            Pic.Offset(0, -1).Font.ColorIndex = 3
            On Error GoTo 0
        End If
    Next Pic
End Sub

• #42081 karlkani aktív tag Fferi50 #42072

  Új Válasz 2019-11-02 12:18:06 #42081

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  karlkani

  aktív tag

  válasz Fferi50 #42072 üzenetére

  Szia!

  Értem.
  Jól sejted, van egy másik lap, onnan nézi a dátumokat.

  (#42073) ny.janos
  Feltételes formázásnál ez a képlet szerepel: =DARABTELI(Ünnepnapok;$C1)>0

  (#42076) Delila_1
  Ezzel a képlettel működik:
  =HA(DARABTELI(Ünnepnapok;C2251)>0;DARABTELI(Ünnepnapok;C2251);"")

  Annak idején segítettél nekem létrehozni ezt a makrót:
  Function Orak(tartomany As Range)
    Dim CV As Range, osszeg As Double, WSD As Worksheet, WF As WorksheetFunction
    
    Set WSD = Sheets("Dátum")
    Set WF = Application.WorksheetFunction
    
        For Each CV In tartomany
        If Not IsNumeric(CV) Or CV = "" Then GoTo Tovabb
        If WF.CountIf(WSD.Columns(4), Cells(CV.Row, "C")) = 0 And _
            WF.CountIf(WSD.Columns(6), Cells(CV.Row, "C")) = 0 And _
            WF.Weekday(Cells(CV.Row, "C"), 2) < 6 Or _
            WF.CountIf(WSD.Columns(2), Cells(CV.Row, "C")) > 0 Then osszeg = osszeg + CV
Tovabb:
    Next
    Orak = osszeg
End Function

  Már többször előfordult, hogy a füzet megnyitásakor az összes olyan cella értéke, ami ezt a makrót használja összegzésre 0-ra módosult. Csak úgy tudtam újraszámoltatni, hogy a cellára álltam, szerkesztőléc, Enter (sok cellánál ez elég macerás), vagy átneveztem a fájlt, vagy töröltem a fájlra vonatkozó bejegyzést a regisztrációs adatbázisból az alábbi helyen.
  HKEY_CURRENT_USER\Software\Microsoft\Office\15.0\Excel\Security\Trusted Documents\TrustRecords

  Ötlet?

• #41478 lappy őstag Doki16 #41477

  Új Válasz 2019-07-31 13:37:47 #41478

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  lappy

  őstag

  válasz Doki16 #41477 üzenetére

  egy vba
  Sub ColorCompanyDuplicates()
'Updateby Extendoffice 20160704
Dim xRg As Range
Dim xTxt As String
Dim xCell As Range
Dim xChar As String
Dim xCellPre As Range
Dim xCIndex As Long
Dim xCol As Collection
Dim I As Long
On Error Resume Next
If ActiveWindow.RangeSelection.Count > 1 Then
xTxt = ActiveWindow.RangeSelection.AddressLocal
Else
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Application.InputBox("please select the data range:", "Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
xCIndex = 2
Set xCol = New Collection
For Each xCell In xRg
On Error Resume Next
xCol.Add xCell, xCell.Text
If Err.Number = 457 Then
xCIndex = xCIndex + 1
Set xCellPre = xCol(xCell.Text)
If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.Interior.ColorIndex = xCIndex
xCell.Interior.ColorIndex = xCellPre.Interior.ColorIndex
ElseIf Err.Number = 9 Then
MsgBox "Too many duplicate companies!", vbCritical, "Excel"
Exit Sub
End If
On Error GoTo 0
Next
End Sub

• #41084 Delila_1 veterán sz_abika #41082

  Új Válasz 2019-05-17 12:44:42 #41084

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Delila_1

  veterán

  válasz sz_abika #41082 üzenetére

  Azonos füzetbe tettem a körte és alma nevű lapokat, amiknek a nevét a Munka1!A1 cellában választom ki, vagy írom be.
  Biztosan át tudod alakítani a makrót úgy, hogy a lapok nevét ne a saját füzetben, hanem a ladak.xls-ben keresse, és onnan másoljon.

  Sub Masolas()
Dim a, lapnev As String

lapnev = Sheets(1).Range("A1")
On Error Resume Next
Set a = Sheets(lapnev) '***
If Err.Number <> 0 Then
MsgBox "Nincs " & lapnev & " nevű lap", vbCritical
Else
Sheets(lapnev).Range("A1:C5").Copy Sheets(1).Range("A2") '*** (sor elején)
End If
On Error GoTo 0
End Sub

  ***-gal jelöltem, hol kell megadnod a másik füzet útvonalát, nevét.

• #41002 Mutt senior tag bartucz911 #41001

  Új Válasz 2019-05-06 20:08:01 #41002

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Mutt

  senior tag

  válasz bartucz911 #41001 üzenetére

  Szia,

  Köszi a pontosítást. Beépített függvényekkel nem sikerült értelmes eredményt kihoznom, de ha UDF (makrós függvény) is játszik, akkor ezt próbáld ki. Alt-F11-el VBE szerkesztő megnyilik, majd ott Insert -> Module és a megjelenő üres ablakba másold be a kódot.

  Function NextMatch(adat As Range)
Dim szam As Range
Dim szamok As New Collection

On Error GoTo ismetlodes
For Each szam In adat
If Len(szam.Value) > 0 Then
szamok.Add szam.Value, CStr(szam.Value)
End If
Next szam

Exit Function

ismetlodes:
NextMatch = szamok.Count

End Function

  Ezek után lesz egy NextMatch függvényed, amely egy tartományt vár ahol a vizsgálandó számok vannak (a tartomány elejét ne fixáld!).

  

  üdv

• #40997 Pakliman tag -szabi- #40996

  Új Válasz 2019-05-05 21:18:42 #40997

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Pakliman

  tag

  válasz -szabi- #40996 üzenetére

  Szia!

  Egy lehetőség:
  (A wiki oldalát jelöld ki CTRL+A-val, majd CTRL+C, aztán a makró indítása)

  Sub Olvas()
Dim oClip As Object
Dim arr
Dim db As Long
Dim i As Long
Dim sor As Long
Dim bKód As Boolean

'Ez a Microsoft Forms 2.0 Object Library "késői kötése" (c:\windows\system32\FM20.DLL)
Set oClip = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")

On Error GoTo Hiba
oClip.GetFromClipboard
'Beolvassuk egy tömbbe a szöveget...
arr = Split(oClip.GetText(1), vbCrLf)
db = UBound(arr)

bKód = False
sor = 0
For i = 0 To db
If arr(i) Like "### ?*" Then
bKód = True
sor = sor + 1
Cells(sor, 1) = Left(arr(i), 3)
Cells(sor, 2) = Mid(arr(i), 5)
End If

If bKód = True Then
If arr(i) Like " ?*" Then
Cells(sor, 3) = Cells(sor, 3) & IIf(Cells(sor, 3) <> "", vbCrLf, "") & Mid(arr(i), 5)
End If
End If
Next i

Hiba:

End Sub

• #40941 Delila_1 veterán visit #40939

  Új Válasz 2019-04-30 11:35:15 #40941

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Delila_1

  veterán

  válasz visit #40939 üzenetére

  Egyszerűbb lenne, ha telepítenéd a naptár vezérlőt, de itt egy ellenőrző makró. A (végül) bevitt dátumot az A1 cellába írja be.

  Sub Dat_ellenorzes()
Dim kelt As String
kelt = Application.InputBox("Add meg dátumot", "Dátum bekérése", , , , , , 2)

'Ellenőrzés
'Teljes hossz
If Len(kelt) <> 10 Then GoTo Hiba

'Pontok helye
If Mid(kelt, 3, 1) <> "." Then GoTo Hiba 'nap
If Mid(kelt, 6, 1) <> "." Then GoTo Hiba 'hónap

'Szám-e
If Not IsNumeric(Left(kelt, 2)) Then GoTo Hiba 'nap
If Not IsNumeric(Mid(kelt, 4, 2)) Then GoTo Hiba 'hónap
If Not IsNumeric(Right(kelt, 4)) Then GoTo Hiba 'év

'Számok helyessége
If Left(kelt, 2) > "31" Then GoTo Hiba 'nap
If Mid(kelt, 4, 2) > "12" Then GoTo Hiba 'hónap

Select Case Mid(kelt, 4, 2) 'hónap
Case "02" 'február
If Right(kelt, 4) / 4 <> Int(Right(kelt, 4) / 4) And Left(kelt, 2) > 28 Then GoTo Hiba
Case "04", "06", "09", "11" '30 napos hónapok
If Left(kelt, 2) > 30 Then GoTo Hiba
End Select

If Right(kelt, 4) / 4 = Int(Right(kelt, 4) / 4) And Mid(kelt, 4, 2) = "02" _
And Left(kelt, 2) > 29 Then GoTo Hiba 'szökőév február

Range("A1") = CDate(kelt)
Exit Sub

Hiba:
Dat_ellenorzes
End Sub

• #40871 Pakliman tag JagdPanther #40870

  Új Válasz 2019-04-23 13:30:45 #40871

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Pakliman

  tag

  válasz JagdPanther #40870 üzenetére

  Szia!

  Ennek így működnie kell:
  Public Sub SendEmail()
Dim olApp As Object
Dim olMail As Object
Dim row_number As Long

Set olApp = CreateObject("Outlook.Application")

On Error Resume Next
For row_number = 2 To 6
Set olMail = olApp.CreateItem(0)
With olMail
.to = Worksheets("Lista1").Cells(row_number, 1)
.Subject = Worksheets("Lista1").Cells(row_number, 2)
.Body = Worksheets("Lista1").Cells(row_number, 3)
.send
End With
Next row_number
On Error GoTo 0

Set olMail = Nothing
Set olApp = Nothing
End Sub

  Javítottam...

• #40461 Pakliman tag tgumis #40459

  Új Válasz 2019-03-20 08:04:06 #40461

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Pakliman

  tag

  válasz tgumis #40459 üzenetére

  Szia!

  Még egyszerűbben, villogtatás nélkül:

  Sub keplet_helyett_ertek()
Dim ws As Worksheet

On Error Resume Next
For Each ws In Worksheets
ws.Cells.SpecialCells(xlCellTypeFormulas, 23).Formula = ws.Cells.SpecialCells(xlCellTypeFormulas, 23).Value
Next ws
On Error GoTo 0
End Sub

  

• #40460 Delila_1 veterán tgumis #40459

  Új Válasz 2019-03-20 06:53:58 #40460

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Delila_1

  veterán

  válasz tgumis #40459 üzenetére

  Sub keplet_helyett_ertek()
Dim lap As Integer, akt_range As Range

For lap = 1 To Sheets.Count
Sheets(lap).Activate 'Lap aktívvá tétele

'Képleteket tartalmazó tartományok kijelölése
On Error Resume Next 'Hibakezelés, ha nincs képlet
Selection.SpecialCells(xlCellTypeFormulas, 23).Select

'A keletkezett területek bejárása és képlet-érték csere
For Each akt_range In Selection.Areas
akt_range.Formula = akt_range.Value
Next
On Error GoTo 0
Next
End Sub

• #40410 Mutt senior tag sz_abika #40408

  Új Válasz 2019-03-12 20:06:03 #40410

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Mutt

  senior tag

  válasz sz_abika #40408 üzenetére

  Szia,

  Itt az én változatom a problémára:

  Dim wsSource As Worksheet
Dim i As Long
Const wsName = " 1234"

i = 0
Do
i = i + 1
On Error Resume Next
Set wsSource = Sheets(Trim("xxx" & Mid(wsName, i, 1)))
On Error GoTo 0
Loop While wsSource Is Nothing And i < Len(wsName)

If wsSource Is Nothing Then
Call MsgBox("A keresett munkalap nem található", vbOKOnly, "Információ")
Else
ActiveCell.Offset(-2, 0).Value = wsSource.Range("A1")
End If

  üdv

• #39629 Delila_1 veterán wednesday #39628

  Új Válasz 2018-11-19 12:21:13 #39629

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Delila_1

  veterán

  válasz wednesday #39628 üzenetére

  Private Sub CommandButton1_Click()
Dim sor As Variant

On Error Resume Next
sor = Sheets(1).Range("A:A").Find(CDate(TextBox1)).Row
If IsEmpty(sor) Then
MsgBox "Nem található " & TextBox1 & " dátum az A oszlopban.", vbCritical
On Error GoTo 0
Exit Sub
Else: MsgBox sor
End If
End Sub

• #39609 Delila_1 veterán Iethau #39608

  Új Válasz 2018-11-15 07:17:17 #39609

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Delila_1

  veterán

  válasz Iethau #39608 üzenetére

  A két lap neve nálam Régi és Friss. Az ügyfelek neve mindkét lapon az A oszlopban van. Írd át a makróban a saját lapjaid nevére.
  A makrót modulba másold, ennek módját lásd a Téma összefoglalóban.

  Sub Frissites()
Dim sor As Long, talal, usor As Long

Sheets("Régi").Activate
usor = Range("A" & Rows.Count).End(xlUp).Row

For sor = usor To 2 Step -1
On Error Resume Next
talal = Application.Match(Cells(sor, "A"), Sheets("Friss").Columns("A"), 0)
If IsError(talal) Then Rows(sor).Delete Shift:=xlUp
On Error GoTo 0
Next
End Sub

• #39495 Delila_1 veterán littleNorbi #39494

  Új Válasz 2018-10-30 17:15:58 #39495

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Delila_1

  veterán

  válasz littleNorbi #39494 üzenetére

  Másold a lap moduljába a makrót.

  Private Sub Worksheet_Change(ByVal Target As Range)
Dim lapnev, ide As Long

If Target.Column = 4 And Target.Value <> "" And Target.Count = 1 Then
On Error Resume Next
Set lapnev = Sheets(Target.Value)
If Err.Number <> 0 Then
MsgBox "Nincs " & Target & " nevű lap", vbCritical
On Error GoTo 0
Exit Sub
End If
ide = Sheets(lapnev).Range("A" & Rows.Count).End(xlUp).Row + 1
Range("A" & Target.Row & ":D" & Target.Row).Copy Sheets(lapnev).Cells(ide, 1)
End If
End Sub

• #38968 Fferi50 Topikgazda kezdosql #38967

  Új Válasz 2018-08-24 21:55:56 #38968

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Fferi50

  Topikgazda

  válasz kezdosql #38967 üzenetére

  Szia!

  Próbáld ki az alábbi makrót:
  Sub atrako()
Dim ws1 As Worksheet, ws2 As Worksheet, cl As Range, xx As Long, helye As Range, kodja As Range, kod As String
Set ws1 = Sheets("Munka1")
On Error Resume Next
Set ws2 = Sheets("Jelent?s")
If Err = 9 Then
Set ws2 = Sheets.Add(after:=Sheets(Sheets.Count))
ws2.Name = "Jelent?s"
Else
ws2.UsedRange.Clear
End If
On Error GoTo 0
With ws1.Range("A1").CurrentRegion
For Each cl In .Columns(1).Cells
If cl.Row > 1 Then
If Application.WorksheetFunction.CountA(.Rows(cl.Row)) > 1 Then
Set helye = ws2.Columns(1).Find(what:=cl, LookIn:=xlValues, lookat:=xlWhole)
If helye Is Nothing Then
Set helye = ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
helye.Value = cl.Value: ws2.Columns.AutoFit
End If
For xx = 1 To .Columns.Count
With cl.Offset(0, xx)
If .Value <> "" Then
kod = Left(.Value, 4)
Set kodja = ws2.Rows(1).Find(what:=kod, LookIn:=xlValues, lookat:=xlWhole)
If kodja Is Nothing Then
Set kodja = ws2.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)
kodja.Value = kod
End If
ws2.Cells(helye.Row, kodja.Column).Value = Mid(.Value, 5)
End If
End With
Next
End If
End If
Next
End With
With ws2.UsedRange
.Range("A1") = "A000"
.Sort key1:=Range("A1"), order1:=xlAscending, Orientation:=xlSortRows, Header:=xlYes
.Sort key1:=Range("A1"), order1:=xlAscending, Orientation:=xlSortColumns, Header:=xlYes
.Range("A1").Clear
End With
End Sub

  Az alapadatok a Munka1 munkalapon vannak, ha más a lap neve, írd át légy szíves. Az új elrendezést a Jelentés nevű munkalapon hozza létre. Ha nincs ilyen nevű lap, akkor megkreálja, ha már van akkor törli a tartalmát - tehát többször is lefuttatható.
  A kód szerinti sorbarendezésnél fontos, hogy az egyes oszlopokban használt négyjegyű kódok első betűje minden oszlopban az előzőnél hátrább legyen az ABC-ben (A011,B0XX,C100 stb). A sorbarendezés akkor is megy, ha nem így van, csak akkor nem lesznek az oszlopok kódjai egymás után.
  Kiindulás:
  
  Eredmény:
  
  Üdv.

• #38737 Delila_1 veterán BalanceR #38735

  Új Válasz 2018-08-02 07:27:40 #38737

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Delila_1

  veterán

  válasz BalanceR #38735 üzenetére

  Legyen mindkét füzet megnyitva. Nálam a Füzet1.xlsm-ben van a makró, modulban, a másik neve Füzet2.xlsx.
  Mindkét füzetben Munka1 a lap neve, és címsort feltételezek.

  Sub Egyeztet()
Dim sor As Long, usor As Long
Dim WS1 As Worksheet, WS2 As Worksheet, talal

Set WS1 = Workbooks("Füzet1.xlsm").Sheets("Munka1")
Set WS2 = Workbooks("Füzet2.xlsx").Sheets("Munka1")

WS1.Activate
usor = Range("A" & Rows.Count).End(xlUp).Row

For sor = usor To 2 Step -1
On Error Resume Next
talal = Application.Match(Cells(sor, 1), WS2.Columns(1), 0)
If IsError(talal) Then
Rows(sor).Delete Shift:=xlUp
On Error GoTo 0
Else
Cells(sor, 9) = WS2.Cells(talal, 9)
End If
Next
End Sub

• #38297 Peddy789 őstag

  Új Válasz 2018-06-11 01:20:30 #38297

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Peddy789

  őstag

  Tiszteletem!
  legujabb excelben:
  importalok egy 160ezer soros txt-t.
  Minden sor elso cellaja egy MB1 MB3 vagy MB4 uzenettel kezdodik
  Ezt a kesobbi feldolgozas miatt szetakarom osztani mondjuk 3 kulon munkalapra, hogy az egyik munkalapon csak az MB1es sorok a masikon csak MB2-vel kezdodo stb sorok maradjnak.

  Szurovel megtudtam oldani hogy kijelolom a szurt sorokat es nyomok egy deletet, azomban igy rengeteg ures sor marad, ami utana elrontja a fugvenyeket amik az adot adat alatti cellat keresik, de igy csak ures cellakat talalnak.

  Hogyan lehet ezt gyorsan elintezni? Hogy szetosszam az adatot 3 munkalapra, es ne maradjanak ures sorok az adatok kozott?

  Probaltam a find&select goto special, select all blank-el hogy aztan ha kivannak jelolve az osszes sort torlom, de ez sajnos nem mukodik, az excel egyszeruen befagy a tulsok sor miatt, fura.

  Nagyon koszonom a valaszokat elore is!

• #38054 Mutt senior tag lcdtv #38040

  Új Válasz 2018-05-16 23:05:46 #38054

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Mutt

  senior tag

  válasz lcdtv #38040 üzenetére

  Szia,

  ...ugyan abban a sorrendben hagyja a füleket mint ahogy van...

  A lenti kód már figyel a sorrendre is és kitörli az új fájl létrehozásakor automatikusan létrejövö felesleges lapo(ka)t.

  A másik hiba pedig abból adódik, hogy mindent másolunk (értéket, képletet, formázást, elnevezett tartományokat stb) és ez ütközést okoz. Mindegyik fájlban ugyanaz a változó van a névkezelőben, így másoláskor ez hibára fog futni.

  A Power Query megoldás csak egy lapot kezel, de viszonylag gyorsan lehet mindegyik lapra elkészíteni a lekérdezesét és legközelebb már csak a frissítésre kell kattintani, hogy az összes lapot legenerálja.

  Sub ttt()
Dim forraslap As Worksheet, cellap As Worksheet
Dim forrasfuzet As Workbook
Dim lap As Worksheet
Dim ureslapok() As String, c As Long

mappak = Array("D:\Mappa\")

If Dir("D:\Mappa\eredmeny.xlsx") <> "" Then Kill "D:\Mappa\eredmeny.xlsx"

For Each mappa In mappak
Set uj = Workbooks.Add

'megjegyezzük a frissen létrehozott fájlban lévő üreslapokat
ReDim ureslapok(1 To uj.Worksheets.Count)
For i = 1 To UBound(ureslapok)
ureslapok(i) = uj.Worksheets(i).Name
Next i

fajl = Dir(mappa & "*.xlsx")

Do While fajl <> ""
Set forrasfuzet = Workbooks.Open(Filename:=mappa & fajl, ReadOnly:=True)

For i = 1 To forrasfuzet.Worksheets.Count
Set forraslap = forrasfuzet.Worksheets(i)
Set cellap = Nothing

If forraslap.Visible = xlSheetVisible Then 'csak a látható lapok érdekelnek
On Error Resume Next
'próbáljuk megnyitni az új füzetben a forrásban található azonos nevű lapot
Set cellap = uj.Worksheets(forraslap.Name)
On Error GoTo 0

If IsArray(ureslapok) Then
For c = 1 To UBound(ureslapok)
If forraslap.Name = ureslapok(c) Then 'ezt a lapot meg kell tartanunk mert volt a forrásfájlban
ureslapok(c) = ""
End If
Next c
End If

'ha nincs még az új füzetben ilyen nevű lap, akkor létrehozzuk
If cellap Is Nothing Then
Set cellap = uj.Worksheets.Add(after:=Worksheets(forraslap.Index - 1)) 'sorrendben adja hozzá
cellap.Name = forraslap.Name
End If

'ha még nincs fejléc akkor másoljuk
If cellap.Range("A1").CurrentRegion.Rows.Count = 1 Then
forraslap.Range("A1", forraslap.Range("A1").SpecialCells(xlLastCell)).Copy cellap.Range("A1")
Else
'ha már van fejléc akkor azt átugorjuk
forraslap.Range("A2", forraslap.Range("A1").SpecialCells(xlLastCell)).Copy _
cellap.Range("A" & cellap.Range("A1").CurrentRegion.Rows.Count + 1)
End If
End If
Next i

'bezárjuk a forrásfájlt
forrasfuzet.Close False

'jöhet az újabb fájl a mappából
fajl = Dir()
Loop

'felesleges munkalapok tőrlése a végső fájlból
Application.DisplayAlerts = False
If IsArray(ureslapok) Then
For c = 1 To UBound(ureslapok)
If ureslapok(c) <> "" Then
uj.Worksheets(ureslapok(c)).Delete 'erre a lapra már nincs szükség
End If
Next c
End If
Application.DisplayAlerts = True

uj.SaveAs mappa & "eredmeny.xlsx"
uj.Close False
Next
MsgBox "Kész"

End Sub

  üdv

• #38039 Mutt senior tag lcdtv #38037

  Új Válasz 2018-05-15 22:35:46 #38039

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Mutt

  senior tag

  válasz lcdtv #38037 üzenetére

  Próbáld meg ezt a javított makrót.

  Sub ttt()
Dim forraslap As Worksheet, cellap As Worksheet
Dim forrasfuzet As Workbook

mappak = Array("D:\Mappa\")

If Dir("D:\Mappa\eredmeny.xlsx") <> "" Then Kill "D:\Mappa\eredmeny.xlsx"

For Each mappa In mappak
Set uj = Workbooks.Add
fajl = Dir(mappa & "*.xlsx")

Do While fajl <> ""
Set forrasfuzet = Workbooks.Open(Filename:=mappa & fajl, ReadOnly:=True)

For i = 1 To forrasfuzet.Worksheets.Count
Set forraslap = forrasfuzet.Worksheets(i)
Set cellap = Nothing

If forraslap.Visible = xlSheetVisible Then 'csak a látható lapok érdekelnek
On Error Resume Next
'próbáljuk megnyitni az új füzetben a forrásban található azonos nevű lapot
Set cellap = uj.Worksheets(forraslap.Name)
On Error GoTo 0

'ha nincs még az új füzetben ilyen nevű lap, akkor létrehozzuk
If cellap Is Nothing Then
Set cellap = uj.Worksheets.Add
cellap.Name = forraslap.Name
End If

'ha még nincs fejléc akkor másoljuk
If cellap.Range("A1").CurrentRegion.Rows.Count = 1 Then
forraslap.Range("A1", forraslap.Range("A1").SpecialCells(xlLastCell)).Copy cellap.Range("A1")
Else
'ha már van fejléc akkor azt átugorjuk
forraslap.Range("A2", forraslap.Range("A1").SpecialCells(xlLastCell)).Copy _
cellap.Range("A" & cellap.Range("A1").CurrentRegion.Rows.Count + 1)
End If
End If
Next i

'bezárjuk a forrásfájlt
forrasfuzet.Close False

'jöhet az újabb fájl a mappából
fajl = Dir()
Loop
uj.SaveAs mappa & "eredmeny.xlsx"
uj.Close False
Next
MsgBox "Kész"

End Sub

• #37893 Delila_1 veterán GreenIT #37884

  Új Válasz 2018-04-21 16:10:11 #37893

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Delila_1

  veterán

  válasz GreenIT #37884 üzenetére

  A Munka1 lap A1 cellájától kezdve bevittem az idei dátumokat, ez A365-ig tart.
  A Munka2 lap A oszlopába az idei ünnepnapok dátumát írtam be, a C-be pedig a "ledolgozós" szombatokét.

  A lenti makró kitörli a Munka1 A oszlopából a megfelelő sorokat.

  Sub Munkanapok()
Dim sor As Integer, WF As WorksheetFunction

Set WF = Application.WorksheetFunction
Sheets("Munka1").Select

For sor = 365 To 1 Step -1
If WF.CountIf(Sheets("Munka2").Columns(3), Cells(sor, 1)) > 0 Then GoTo Tovabb 'szombati munkanap
If WF.CountIf(Sheets("Munka2").Columns(1), Cells(sor, 1)) > 0 Then Rows(sor).Delete Shift:=xlUp 'ünnepnap
If WF.Weekday(Cells(sor, 1), 2) > 5 Then Rows(sor).Delete Shift:=xlUp 'hétvége
Tovabb:
Next
End Sub

  Amelyik listában nem akarod a hétvégéket törölni, annál tedd megjegyzésbe a hétvégés makrós sort úgy, hogy a sor elejére aposztrófot teszel.

• #37665 p5quser tag Fferi50 #37664

  Új Válasz 2018-03-28 14:55:25 #37665

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  p5quser

  tag

  válasz Fferi50 #37664 üzenetére

  Sub SearchFolders()
'UpdatebyKutoolsforExcel20151202
Dim xFso As Object
Dim xFld As Object
Dim xStrSearch As String
Dim xStrPath As String
Dim xStrFile As String
Dim xOut As Worksheet
Dim xWb As Workbook
Dim xWk As Worksheet
Dim xRow As Long
Dim xFound As Range
Dim xStrAddress As String
Dim xFileDialog As FileDialog
Dim xUpdate As Boolean
Dim xCount As Long
On Error GoTo ErrHandler
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a forlder"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
xStrSearch = "KTE"
xUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
Set xOut = Worksheets.Add
xRow = 1
With xOut
.Cells(xRow, 1) = "Workbook"
.Cells(xRow, 2) = "Worksheet"
.Cells(xRow, 3) = "Cell"
.Cells(xRow, 4) = "Text in Cell"
Set xFso = CreateObject("Scripting.FileSystemObject")
Set xFld = xFso.GetFolder(xStrPath)
xStrFile = Dir(xStrPath & "\*.xls*")
Do While xStrFile <> ""
Set xWb = Workbooks.Open(Filename:=xStrPath & "\" & xStrFile, UpdateLinks:=0, ReadOnly:=True, AddToMRU:=False)
For Each xWk In xWb.Worksheets
Set xFound = xWk.UsedRange.Find(xStrSearch)
If Not xFound Is Nothing Then
xStrAddress = xFound.Address
End If
Do
If xFound Is Nothing Then
Exit Do
Else
xCount = xCount + 1
xRow = xRow + 1
.Cells(xRow, 1) = xWb.Name
.Cells(xRow, 2) = xWk.Name
.Cells(xRow, 3) = xFound.Address
.Cells(xRow, 4) = xFound.Value
End If
Set xFound = xWk.Cells.FindNext(After:=xFound)
Loop While xStrAddress <> xFound.Address
Next
xWb.Close (False)
xStrFile = Dir
Loop
.Columns("A:D").EntireColumn.AutoFit
End With
MsgBox xCount & "cells have been found", , "Kutools for Excel"
ExitHandler:
Set xOut = Nothing
Set xWk = Nothing
Set xWb = Nothing
Set xFld = Nothing
Set xFso = Nothing
Application.ScreenUpdating = xUpdate
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub

  Ebből a szösszenetből lett plasztikázva.
  Köszönöm a segítséget!

• #37654 p5quser tag Fferi50 #37652

  Új Válasz 2018-03-28 08:38:05 #37654

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  p5quser

  tag

  válasz Fferi50 #37652 üzenetére

  Üdv!
  Nem teljesen világos, hová kéne beszúrnom a copy parancsot. Ahová raktam, ott range copy metódus hibával elszállt.
  Most így néz ki a script jelenleg, de így "előjeltelen"

  Private Sub CommandButton1_Click()
Dim xFso As Object
Dim xFld As Object
Dim xStrSearch As String
Dim xStrPath As String
Dim xStrFile As String
Dim xOut As Worksheet
Dim xWb As Workbook
Dim xWk As Worksheet
Dim xRow As Long
Dim xFound As Range
Dim xStrAddress As String
Dim xFileDialog As FileDialog
Dim xUpdate As Boolean
Dim xCount As Long
On Error GoTo ErrHandler
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a forlder"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
xStrSearch = "elszámol"
xUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
Set xOut = Worksheets.Add
xRow = 1
With xOut
.Cells(xRow, 1) = "Munkafüzet"
.Cells(xRow, 2) = "Munkalap"
.Cells(xRow, 3) = "Cella"
.Cells(xRow, 4) = "Találat"
.Cells(xRow, 5) = "Név"
.Cells(xRow, 6) = "Összeg"
Set xFso = CreateObject("Scripting.FileSystemObject")
Set xFld = xFso.GetFolder(xStrPath)
xStrFile = Dir(xStrPath & "\*.xls*")
Do While xStrFile <> ""
Set xWb = Workbooks.Open(Filename:=xStrPath & "\" & xStrFile, UpdateLinks:=0, ReadOnly:=True, AddToMRU:=False)
For Each xWk In xWb.Worksheets
Set xFound = xWk.UsedRange.Find(xStrSearch)
Set xFn = xWk.UsedRange.Find(xStrSearch)
If Not xFound Is Nothing Then
xStrAddress = xFound.Address
xNev = xFound.Offset(0, -1).Value
xOssz = xFound.Offset(0, 1).Value
End If
Do
If xFound Is Nothing Then
Exit Do
Else
xCount = xCount + 1
xRow = xRow + 1
.Cells(xRow, 1) = xWb.Name
.Cells(xRow, 2) = xWk.Name
.Cells(xRow, 3) = xFound.Address
.Cells(xRow, 4) = xFound.Value
.Cells(xRow, 5) = xNev
.Cells(xRow, 6) = xOssz
End If
Set xFound = xWk.Cells.FindNext(After:=xFound)
Loop While xStrAddress <> xFound.Address
Next
xWb.Close (False)
xStrFile = Dir
Loop
.Columns("A:F").EntireColumn.AutoFit
End With
MsgBox xCount & " egyezést találtam", , "Elszámolósdi"
ExitHandler:
Set xOut = Nothing
Set xWk = Nothing
Set xWb = Nothing
Set xFld = Nothing
Set xFso = Nothing
Application.ScreenUpdating = xUpdate
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub

  Köszönöm!

• #37629 p5quser tag

  Új Válasz 2018-03-25 11:58:26 #37629

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  p5quser

  tag

  Sziasztok!
  Ismét a segítségeteket kérném. Adott egy munkafüzet, a hónap napjaira bontott munkalapokkal. Ebben a munkafüzetben kellene rákeresnem az "elszámolás" szóra minden munkalapon, kilistáztatva a napot, az elszámolás szót, egy oszloppal a találat előtti értéket és egy oszloppal a találat utáni értéket.
  Alább a script amit találtam, teszi a dolgát, csak nem tudom hogy irassam ki vele az eltolt oszlopok értékeit.

  Private Sub CommandButton1_Click()
Dim xFso As Object
Dim xFld As Object
Dim xStrSearch As String
Dim xStrPath As String
Dim xStrFile As String
Dim xOut As Worksheet
Dim xWb As Workbook
Dim xWk As Worksheet
Dim xRow As Long
Dim xFound As Range
Dim xStrAddress As String
Dim xFileDialog As FileDialog
Dim xUpdate As Boolean
Dim xCount As Long
On Error GoTo ErrHandler
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a forlder"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
xStrSearch = "elszámol"
xUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
Set xOut = Worksheets.Add
xRow = 1
With xOut
.Cells(xRow, 1) = "Workbook"
.Cells(xRow, 2) = "Worksheet"
.Cells(xRow, 3) = "Cella"
.Cells(xRow, 4) = "Találat"
.Cells(xRow, 5) = "Összeg"
.Cells(xRow, 6) = "Név"
Set xFso = CreateObject("Scripting.FileSystemObject")
Set xFld = xFso.GetFolder(xStrPath)
xStrFile = Dir(xStrPath & "\*.xls*")
Do While xStrFile <> ""
Set xWb = Workbooks.Open(Filename:=xStrPath & "\" & xStrFile, UpdateLinks:=0, ReadOnly:=True, AddToMRU:=False)
For Each xWk In xWb.Worksheets
Set xFound = xWk.UsedRange.Find(xStrSearch)
If Not xFound Is Nothing Then
xStrAddress = xFound.Address
End If
Do
If xFound Is Nothing Then
Exit Do
Else
xCount = xCount + 1
xRow = xRow + 1
.Cells(xRow, 1) = xWb.Name
.Cells(xRow, 2) = xWk.Name
.Cells(xRow, 3) = xFound.Address
.Cells(xRow, 4) = xFound.Value
.Cells(xRow, 5) = xFound.Value
.Cells(xRow, 6) = xFound.Value
End If
Set xFound = xWk.Cells.FindNext(After:=xFound)
Loop While xStrAddress <> xFound.Address
Next
xWb.Close (False)
xStrFile = Dir
Loop
.Columns("A:D").EntireColumn.AutoFit
End With
MsgBox xCount & " egyezést találtam", , "Elszámolós"
ExitHandler:
Set xOut = Nothing
Set xWk = Nothing
Set xWb = Nothing
Set xFld = Nothing
Set xFso = Nothing
Application.ScreenUpdating = xUpdate
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub

  Ezeket szeretném megváltoztatni;
  .Cells(xRow, 5) = xFound.Value (találat_oszlop -1, találat_sor)
.Cells(xRow, 6) = xFound.Value (találat_oszlop +1, találat_sor)
  Előre is köszönöm!

• #36630 Fferi50 Topikgazda the radish #36629

  Új Válasz 2017-11-24 00:07:26 #36630

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Fferi50

  Topikgazda

  válasz the radish #36629 üzenetére

  Szia!

  Arra van lehetőség, hogy a futásidejű hibák ne okozzanak leállást, illetve korrigálhatók legyenek. Nézz utána az On Error Goto ill. az On Error Resume utasításoknak a Help-ben.

  Üdv.

• #36507 bsh addikt

  Új Válasz 2017-11-13 14:01:37 #36507

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  bsh

  addikt

  Üdv.
  Próbálnék egy olyat megoldani, hogy egy bazihosszú képlet helyett egy rövidebb saját függvényt használni, ami ugyanazt csinálná. Így még pár extra egyszerűsítést is bele tudnék mókolni.
  Application.Caller-rel megpróbálnám kiolvasni, hogy hányadik sorból hívódik a képlet (így nem kéne megadni paraméternek semmit)
  De random módon olyan hibákat csinál, hogy pl. azt mondja, hogy "Application.WorksheetFunction osztály Match tulajdonsága nem érhető el" (miközben watch szerint elérhető) meg ilyenek...
  Ez az Application.Caller-t nem ismerem, gondolom ezzel kell valamit trükközni? Mert magában a funkcióm az működik.

  Public Function KKERES() As Double
KKERES = 0
If TypeOf Application.Caller Is Range Then
Dim Caller As Range
Set Caller = Application.Caller
Dim Z As String
Z = Munka2.Cells(Caller.Row, 2).Text
If Z <> "" Then
On Error GoTo notfound
X = Caller.Application.WorksheetFunction.Match(Z, Munka3.Range("B:B"), 0)
If IsError(X) Then
Y = Caller.Application.WorksheetFunction.Match(Z, Munka4.Range("B:B"), 0)
If IsError(Y) Then Y = Caller.Application.WorksheetFunction.Match(Z, Munka4.Range("C:C"), 0)
If IsError(Y) Then
On Error GoTo 0
KKERES = 0
Exit Function
Else
On Error GoTo 0
If Caller.Column = 5 Then
KKERES = Munka4.Cells(Y, 5).Value
Exit Function
End If
If Caller.Column = 6 Then
KKERES = Munka4.Cells(Y, 6).Value
Exit Function
End If
End If
Else
On Error GoTo 0
If Caller.Column = 5 Then
KKERES = Munka3.Cells(X, 5).Value
Exit Function
End If
If Caller.Column = 6 Then
KKERES = Munka3.Cells(X, 6).Value
Exit Function
End If
End If
End If
End If
notfound:
End Function

• #36208 Pakliman tag ben800 #36204

  Új Válasz 2017-09-28 13:56:07 #36208

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Pakliman

  tag

  válasz ben800 #36204 üzenetére

  Úgy nagyjából valami ilyesmi...

  Public Sub AdatMásolás()
Dim wbT As Workbook 'A "kis" munkafüzet, ami tartalmazza a...
Dim wsT As Worksheet '..munkalapokat (1-től 12-ig)
Dim cT As Long 'Számláló (a 19 db táblázathoz)
Dim usT As Long 'A kis táblázat utolsó sora

Dim aws As Worksheet 'Csak azért, hogy ne ActiveSheet legyen:)
Dim us As Long 'A FŐ táblázat utolsó sora

Dim sor As Long 'Egyszerű számláló
Dim talált 'A keresett azonosító cellacíme lesz

Set aws = ActiveSheet

For cT = 1 To 19
On Error GoTo Hiba
Set wbT = Workbooks.Open("a feldolgozandó kis táblázat neve útvonallal együtt")
For Each wsT In wbT.Worksheets
usT = wsT.Cells(wsT.Rows.Count, 1).End(xlUp).Row
For sor = 2 To usT 'Feltételezve, hogy az 1. sor fejléc
'Az azonosító az 1. oszlopban van
'!!! A FŐ táblában (aws) keressük a kis táblás azonosítót (wsT.Cells(sor, 1)) !!!
Set talált = aws.Columns(1).Find(What:=wsT.Cells(sor, 1), LookAt:=xlWhole, MatchCase:=True)
'Ha találtunk, akkor nem csinálunk semmit.
'Ellenben:
If talált Is Nothing Then
us = aws.Cells(aws.Rows.Count, 1).End(xlUp).Row
aws.Cells(us + 1, 1) = "azonosító"
aws.Cells(us + 1, 2) = "adat1"
aws.Cells(us + 1, 3) = "adat2"
aws.Cells(us + 1, 4) = "adat3"
aws.Cells(us + 1, 5) = "adat4"
aws.Cells(us + 1, 6) = "adat5"
'...

End If

Next sor
Next wsT

On Error GoTo 0
wbT.Close SaveChanges:=False
Next cT

Set wbT = Nothing
Set wsT = Nothing
Set aws = Nothing
GoTo Vége

Hiba:
'Hibakezelés, pl. ha nincs olyan fájl stb.
'Ha nem kell tenni semmit hiány esetén, akkor egyszerűen csak..
Resume Next

Vége:

End Sub

• #35929 Delila_1 veterán föccer #35928

  Új Válasz 2017-08-04 17:39:59 #35929

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Delila_1

  veterán

  válasz föccer #35928 üzenetére

  Dim a

On Error Resume Next
Set a = Sheets(Range("C2"))
If Err.Number <> 0 Then
Sheets.Add.Name = Range("C2")
On Error GoTo 0
End If

Columns("A:D").ColumnWidth = 20

  Az alsó sor az A:D oszlopok szélességét állítja be, és teszi ezt az újonnan létrehozott lapon, mert hivatalból az új lap az aktív. Ha másik lapon akarod a szélességet beállítani, akkor ezt jelezni kell.

  Sheets(1).Columns("A:D").ColumnWidth = 20

• #35721 Delila_1 veterán Acustic #35720

  Új Válasz 2017-07-14 07:39:45 #35721

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Delila_1

  veterán

  válasz Acustic #35720 üzenetére

  Szia Attila!

  Az első makrót a laphoz kell rendelned. Mikor a H oszlopba beírsz, vagy bemásolsz egy nevet, akkor ez a cella, valamint az A oszlopban lévő, azonos tartalmú cellák háttere sárga lesz. Az első, A oszlopban lévő név cellája lesz kijelölt.

  Private Sub Worksheet_Change(ByVal Target As Range)
Dim ter As Range, CV As Object
If Target.Column = 8 Then
Set ter = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
For Each CV In ter
If CV = Target Then
CV.Interior.Color = vbYellow
CV.HorizontalAlignment = xlRight
CV.VerticalAlignment = xlTop
End If
Next
Range(Target.Address).Interior.Color = vbYellow
Range(Target.Address).HorizontalAlignment = xlRight
Range(Target.Address).VerticalAlignment = xlTop
Range("A" & Application.WorksheetFunction.Match(Target, Columns(1), 0)).Select
End If
End Sub

  A második makró modulba kerül. Ehhez rendelj billentyű kombinációt, aminek hatására indul a makró. Az aktuális cella háttere piros lesz, a kijelölés a következő, ilyen nevet tartalmazó cellára ugrik az A oszlopban. Mikor a kombinációval befejezted a szereplőhöz tartozó összes cella átszínezését, a H oszlopban is pirosra vált a név cellája, ez lesz kijelölt. Üzenetet kapsz, hogy a szereplő összes sora kész van.

  Sub Piros()
Dim sor, nev As String

If Selection.Column = 1 Then
nev = Selection.Value
On Error GoTo KeszVan
sor = Range("A" & Selection.Row + 1 & ":A10000").Find(nev).Row
Selection.Interior.Color = vbRed
Selection.HorizontalAlignment = xlLeft
Cells(sor, "A").Select
End If
Exit Sub

KeszVan:
Selection.Interior.Color = vbRed
Selection.HorizontalAlignment = xlLeft
sor = Columns(8).Find(nev).Row
Cells(sor, "H").Interior.Color = vbRed
Cells(sor, "H").HorizontalAlignment = xlLeft
Cells(sor, "H").Select

MsgBox nev & " minden sora kész van.", vbInformation, "Értesítés"
End Sub

  Jó munkát! Üdv
  Kati

• #35579 Pakliman tag

  Új Válasz 2017-06-28 15:25:05 #35579

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Pakliman

  tag

  Sziasztok!

  Ha valakinek esetleg kellene egy ilyen:

  Public Function Darabolt(darabolandó, rész As Long, Optional elválasztó As String = " ", Optional elválasztó_egyben_használandó As Boolean = True) As String
Dim delim
Dim i As Long

If elválasztó_egyben_használandó Then
delim = elválasztó
Else
delim = Mid(elválasztó, 1, 1)
For i = 2 To Len(elválasztó)
darabolandó = Replace(darabolandó, Mid(elválasztó, i, 1), delim)
Next i
End If

On Error GoTo Hiba
Darabolt = Split(darabolandó, delim)(rész - 1)

Exit Function

Hiba:
Darabolt = ""
End Function

  Használata:

  darabolandó -> bármilyen szöveg, amiből egy részt akarunk visszakapni
  rész -> az elválasztók által határolt n-edik rész
  elválasztó -> ezt a karaktert vagy szöveget értelmezzük elválasztóként -> ha nincs megadva, akkor 1 db szóköz
  elválasztó_egyben_használandó -> lásd lentebb

  Darabolt("A darabolandó szöveg-> kukac@excel.hu",2) -> "darabolandó"
  Darabolt("A darabolandó szöveg-> kukac@excel.hu",4) -> "kukac@excel.hu"
  Darabolt("A darabolandó szöveg-> kukac@excel.hu",1,"->") -> "A darabolandó szöveg"
  Darabolt("A darabolandó szöveg-> kukac@excel.hu",2,"->") -> " kukac@excel.hu"

  Darabolt("A darabolandó szöveg-> kukac@excel.hu",1,"->",False) -> "A darabolandó szöveg"
  Darabolt("A darabolandó szöveg-> kukac@excel.hu",2,"->",False) -> ""
  Darabolt("A darabolandó szöveg-> kukac@excel.hu",3,"->",False) -> " kukac@excel.hu"

  Darabolt("A darabolandó szöveg-> kukac@excel.hu",3,"->@",False) -> " kukac"
  Darabolt("A darabolandó szöveg-> kukac@excel.hu",4,"->@",False) -> "excel.hu"

  Darabolt("A darabolandó szöveg-> kukac@excel.hu",1,"->@",True) -> "A darabolandó szöveg-> kukac@excel.hu"

  Használható VBA-ban és cellában egyaránt.

• #35506 Fferi50 Topikgazda Capella #35504

  Új Válasz 2017-06-18 13:19:48 #35506

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Fferi50

  Topikgazda

  válasz Capella #35504 üzenetére

  Szia!

  Ha J2 cellában egy cím keletkezik a képlet alapján akkor egyszerűen:
  Application.Goto Reference:=Range(Range("J2").Value)
  A Goto aktíválja is az adott cellát.

  Így az összes többi sor teljesen felesleges, elegendő ez az egy.
  Ha pedig az éppen aktuális celládban van a kívánt cím akkor:
  Application.Goto Reference:=Range(Selection.Value)

  Üdv.

• #35505 poffsoft veterán Capella #35504

  Új Válasz 2017-06-18 13:18:36 #35505

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  poffsoft

  veterán

  válasz Capella #35504 üzenetére

  A J2 tartalma egészen pontosan milyen formátumban tartalmazza az utolsó cella címét? R1C1, vagy A1 vagy más? Ha A1 a formátum:
  Sub GotoLastCell()
'
' GotoLastCell Makró
'
' Billentyűparancs: Ctrl+n
'
' Range("J2").Select
' Selection.Copy
' Application.Goto Reference:="R3135C6"
' ActiveCell.Select
' Application.CutCopyMode = False
Range(Range("J2")).Select

End Sub

• #35504 Capella senior tag

  Új Válasz 2017-06-18 12:39:26 #35504

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Capella

  senior tag

  Szeretnék egy táblázat legutolsó vagy az általam megadott cellájába ugrani egy makróval. Hogy mi az utolsó, azt én határozom meg egy képlettel a J2 cellában.
  Gondoltam az F5 ugrás gombot használva és bemásolva ide a cellatartalmat makrórögzítéssel megoldom.
  Azonban nem működik rendesen a makró, mert fixen bedrótozva mindig a rögzítéskor bemásolt értékhez ugrik, vagy ezt mindig nekem kell kézzel átírnom a makróban, ha változtatni akarok.
  Azt látom, hogy a Application.Goto Reference:="R3135C6" sorral van baj.
  Hogyan lehetne rávenni a makrót átszerkesztve, hogy mindig a J2 cellatartalomra ugorjon?

  Sub GotoLastCell()
'
' GotoLastCell Makró
'
' Billentyűparancs: Ctrl+n
'
Range("J2").Select
Selection.Copy
Application.Goto Reference:="R3135C6"
ActiveCell.Select
Application.CutCopyMode = False
End Sub

• #35477 RAiN91 őstag

  Új Válasz 2017-06-13 20:11:32 #35477

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  RAiN91

  őstag

  Sziasztok

  Van egy ilyenem, 3 excel táblában is.

  Private Sub worksheet_idozito()
  1
  Cells(6, 6) = Cells(9, 8)
  ido = Timer + 0.2
  Do While (Timer < ido)
  DoEvents
  Loop
  If Cells(9, 8) < Cells(6, 6) Then
  Cells(6, 7) = Cells(9, 8)
  ido = Timer + 1.5
  Do While (Timer < ido)
  DoEvents
  Loop
  Cells(6, 8) = Cells(9, 8)
  ido = Timer + 1.5
  Do While (Timer < ido)
  DoEvents
  Loop
  Cells(6, 9) = Cells(9, 8)
  ido = Timer + 1.5
  Do While (Timer < ido)
  DoEvents
  Loop
  Else
  End If

  GoTo 1
  End Sub

  Hogyan lehet megoldani, hogy ha elindítom az excel fájlt, akkor ezek automatikusan fussanak?
  Ha kézzel indítom, akkor csak az egyik worksheetben fut.

• #35395 Juditta_56 aktív tag

  Új Válasz 2017-06-05 14:16:32 #35395

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Juditta_56

  aktív tag

  Sziasztok!

  Már minden lehetséges netes forrást végigkutattam, de nem jövök rá, hogy miért nem működik a következő makró (bemásolom az egészet, a második nagybetűs komment sor alatti sorra dobja a hibát):

  Sub EllMasol()
'
Dim ControlNeve, LapNeve, osszlap, SegLap As String
Dim fso As Object
' Dim ControlFile As Workbook
Set fso = CreateObject("Scripting.FileSystemObject")
fileExists = fso.fileExists("C:\Users\Desktop\Test\journals.xlsx")

'csak ebben a modulban:
Dim EllSor, EllOszl, JelSor, HibaOszl As Integer
Dim OszKonyvt, OszNeve As String
Dim OsszSor, OsszOszl, OsszOszlMax As Integer

' On Error GoTo Errorcatch

ControlNeve = ActiveWorkbook.Sheets(1).Range("AW1")

'EZ SEM MŰKÖDIK, DE EZT KIKERÜLTEM
' Set ControlFile = Workbooks(ControlNeve)

osszlap = Workbooks(ControlNeve).Worksheets("Összesítő").Name
SegLap = Workbooks(ControlNeve).Worksheets("Segéd").Name


If Environ("username") = azennevem Then 'Ide eredetileg az itthoni felhasználónevem,
'otthon
OszKonyvt = azenkönyvtáram 'ide meg az adott könyvtár neve van beírva...
Else
'benti
OszKonyvt = ActiveWorkbook.Sheet(1).Range("AY1")
End If

OszNeve = Workbooks(ControlNeve).Sheets(1).Range("AZ1")
EllSor = Workbooks(ControlNeve).Sheets(osszlap).Range("IJ1")
EllOszl = Workbooks(ControlNeve).Sheets(osszlap).Range("IK1")
JelSor = Workbooks(ControlNeve).Sheets(osszlap).Range("IL1")
HibaOszl = Workbooks(ControlNeve).Sheets(osszlap).Range("IM1")
fileExists = fso.fileExists(OszKonyvt & OszNeve)

Workbooks.Open (OszKonyvt & OszNeve) 'Megnyitja
Windows(OszNeve).Activate
Sheets(1).Activate
OsszSor = Range("CJ31")
OsszOszl = Range("A" & OsszSor)
OsszOszlMax = Range("A" & OsszSor + 1)

Range(Cells(OsszSor + 10, 4), Cells(OsszSor + 18, 4)).Copy 'Kimásolja

'ENNÉL A SORNÁL HIBAÜZENET: "Run-time error '1004'. Application-defined or operation-defined error." MIÉRT?
Workbooks(ControlNeve).Sheets(osszlap).Range(Cells(EllSor + 24, HibaOszl)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False

Range(Cells(OsszSor + 20, OsszOszl), Cells(OsszSor + 18, OsszOszlMax)).Copy
Workbooks(ControlNeve).Sheets(osszlap).Range(Cells(EllSor + 24, EllOszl)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False

Range(Cells(OsszSor, OsszOszl), Cells(OsszSor + 8, OsszOszlMax)).Copy
Workbooks(ControlNeve).Sheets(osszlap).Range(Cells(EllSor, EllOszl)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False

Range(Cells(OsszSor + 10, OsszOszl), Cells(OsszSor + 19, OsszOszlMax)).Copy
Workbooks(ControlNeve).Sheets(osszlap).Range(Cells(JelSor, EllOszl)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False

Exit Sub
'Errorcatch: MsgBox Err.Description
End Sub

  A Debugnál szépen kiírja az összes változó nevét, (fájl, sorok-oszlopok száma), tehát nem azokkal van baja...

  Köszönöm szépen előre is a segítséget!

• #35170 Pakliman tag the radish #35165

  Új Válasz 2017-05-12 09:45:51 #35170

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Pakliman

  tag

  válasz the radish #35165 üzenetére

  Szia!

  Ezt "kényszerből" írtam, mert sokszor volt/van szükségem darabolásra.
  Használható cellában és makróban egyaránt.

  Public Function Darabolt(darabolandó, rész As Long, Optional elválasztó As String = " ", Optional elválasztó_egyben_használandó As Boolean = True, Optional trim As Boolean = True) As String
Dim delim
Dim s
Dim i As Long

s = IIf(trim, Application.Trim(darabolandó), darabolandó)

If elválasztó_egyben_használandó Then
delim = elválasztó
Else
delim = Mid(elválasztó, 1, 1)
For i = 2 To Len(elválasztó)
s = Replace(s, Mid(elválasztó, i, 1), delim)
Next i
End If

On Error GoTo Hiba
Darabolt = Split(s, delim)(rész - 1)

Exit Function

Hiba:
Darabolt = ""
End Function

  Használata:
darabolandó= "dara bolandó napok"
rész= lásd eredményeknél
elválasztó= " n" 'ha nem adod meg, akkor 1 db szóköz
' elválasztó_egyben_használandó= ha nem adod meg, akkor IGAZ
' trim= ha nem adod meg, akkor IGAZ



elválasztó_egyben_használandó= HAMIS (=a szóköz is és az n is elválasztóként használandó)
trim= HAMIS (=feldolgozás előtt a dupla/tripla stb szóközöket NEM cseréli 1 db szóközre)
eredmény rész=1 --> "dara"
eredmény rész=2 --> ""
eredmény rész=3 --> ""
eredmény rész=4 --> ""
eredmény rész=5 --> ""
eredmény rész=6 --> "bola"
eredmény rész=7 --> "dó"
eredmény rész=8 --> ""
eredmény rész=8 --> "apok"

'-------------------------------------------------
darabolandó= "dara bolandó napok"
elválasztó= " n"

elválasztó_egyben_használandó= IGAZ (=KIZÁRÓLAG a " n" sztring az elválasztó!!)
trim= IGAZ (=feldolgozás előtt a dupla/tripla stb szóközöket kicseréli 1 db szóközre)
eredmény rész=1 --> "dara bolandó"
eredmény rész=2 --> "apok"

• #35122 Delila_1 veterán Pikkolo^^ #35119

  Új Válasz 2017-05-08 06:14:42 #35122

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Delila_1

  veterán

  válasz Pikkolo^^ #35119 üzenetére

  On Error Resume Next
Set a = Sheets(sheetnev)
If Err.Number <> 0 Then
MsgBox "Nincs ilyen"
Else
MsgBox "Van ilyen"
End If
On Error Goto 0

• #33446 Fferi50 Topikgazda szőröscica #33445

  Új Válasz 2016-12-14 22:42:00 #33446

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Fferi50

  Topikgazda

  válasz szőröscica #33445 üzenetére

  Szia!

  Az egyik lehetőség, hogy hibakezelést építesz be: On Error Resume Next sorral.
  Ha tudod, hogy csak ez lehet a hiba, akkor semmit nem is kell tenned, csak a programszekció végén visszaadni a hibakezelést a VBA-nak: On Error Goto 0
  Ez azért szerintem kissé kockázatos, bár természetesen minden sor után meg lehet nézni, milyen hiba keletkezett (If ERR= x akkor mi legyen - a hibaszámokat megtalálod a helpben).

  Másik megoldás, hogy végigmész a tételeken:
  Dim pvti as PivotItem
For Each pvti in ,PivotItems
If pvti.Name = "Level 2" Or pvti.Name = "Level 1" Or pvti.Name = "Level 3" Then pvti.Visible = True
Next

  Nekem ez utóbbi jobban tetszik.

  Üdv.

• #33051 Delila_1 veterán mormota #33050

  Új Válasz 2016-10-25 14:38:01 #33051

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Delila_1

  veterán

  válasz mormota #33050 üzenetére

  Egy üres füzetben modulba másold be a makrót.

  Sub Szetcincalas()
Dim sor As Long, usor As Long
Dim WSF As Worksheet, WSS As Worksheet
Const utvonal = "D:\Tmp\" 'ide jön a saját útvonalad

On Error Resume Next
Workbooks.Open Filename:=utvonal & "Forrás.xlsx"
On Error GoTo 0

On Error Resume Next
Workbooks.Open Filename:=utvonal & "Sablon.xlsb"
On Error GoTo 0

Set WSF = Workbooks("Forrás.xlsx").Sheets(1) 'saját füzeted és lapod neve
Set WSS = Workbooks("Sablon.xlsb").Sheets(1) 'saját füzeted és lapod neve

usor = WSF.Range("F" & Rows.Count).End(xlUp).Row

WSS.Activate
For sor = 2 To usor
Cells(1, "C") = WSF.Cells(sor, "F")
Cells(2, "C") = WSF.Cells(sor, "G")
Cells(3, "C") = WSF.Cells(sor, "L")
Cells(4, "C") = WSF.Cells(sor, "H")

ActiveWorkbook.SaveAs Filename:=utvonal & Range("C3") & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Next

MsgBox "Kész"
End Sub

  Írd át a 3 jelzett sorban az útvonalat, a fájlneveket, és hogy hányadik lapon vannak az adatok a forrás és a sablon füzetekben. Adj rá mentést, Makrós.xlsm-ként.

  A makró megnyitja a sablon és forrás fájlokat, elvégzi a másolást, menti az aktuális C3 néven a fájlt.