- Mobil flották
- Fotók, videók mobillal
- Ilyen lesz a Fairphone 6
- Hivatalos a OnePlus 13 startdátuma
- Érkezik a Samsung Health előfizetés?
- Nothing Phone (3a) és (3a) Pro - az ügyes meg sasszemű
- Motorola Edge 50 Neo - az egyensúly gyengesége
- Azonnali mobilos kérdések órája
- iPhone topik
- Xiaomi Watch 2 Pro - oké, Google, itt vagyunk mi is
-
Mobilarena
A Microsoft Excel topic célja segítséget kérni és nyújtani Excellel kapcsolatos problémákra.
Kérdés felvetése előtt olvasd el, ha még nem tetted.
Új hozzászólás Aktív témák
-
Mutt
senior tag
Szia,
Makró nélküli megoldások erre a problémára:
1. Tömbfüggvény: az E-oszlopba előbb fel kell vinned ami alapján csoportosítani akarsz.
=TEXTJOIN(", ";TRUE;IF($A$1:$A$3000=E1;$B$1:$B$3000;""))3000 soron is gyorsan lefut, előnye hogy automatikusan frissül, viszont a duplikációkat nem szűri.
2. Power Pivot: ezt kézzel kell frissíteni, képes a duplikácókat is kiszűrni ha szükséges.
a. Kell egy fejléc az első sorba és táblázattá kell alakítani az adatsort.
b. Beszúrás -> Kimutatás (Pivot) de itt fontos hogy legyen bepipálva alul az adatmodellhez hozzáadás.
c. Az A-oszlop kerül a sorok részbe.
d. Jobb klikk a kimutatás tervezőben az adatforráson (nekem Table1-nek hívja) és Add measure (Új mérték)
e. Az ablakot így töltsd ki:
A CONCATENATEX függvényben az első paraméter a forrás neve (jelen esetben Table1-ben vannak az adatok), a második a mező amit összekell fűzni (ez a Table1-en belüli Érték oszlop), a végén pedig hogy mivel legyenek az értékek elválasztva.
Ha az ismétlődéseket nem szeretnéd listázni, akkor a forrást előbb vagy a VALUES vagy a DISTINCT függvényen kell végig pörgetni:
=CONCATENATEX(VALUES(Table1[Érték]);Table1[Érték];", ")=CONCATENATEX(DISTINCT(Table1[Érték]);Table1[Érték];", ")f. Az új mértéket húzd be a values / értékek részbe.
g. Formázd az eredményt szükség szerint.3. Power Query: ez sem fog automatikusan frissülni, de itt is tudsz ismétléseket kivenni vagy akár sorrendet módosítani.
a. Kell egy fejléc az első sorba és táblázattá kell alakítani az adatsort.
b. Data -> From table (Adatok -> Beolvasás táblázatból) opciót használd.
c. Ha szeretnéd az ismétléseket kiszűrni, akkor jelöld ki mindkét oszlopot és Home -> Remove rows -> Remove duplicates.
d. Ha szeretnéd, hogy növekvő/csökkenő sorrendben legyenek az értékek kiíratva, akkor pedig.jelöld ki a második oszlopot és Home menű alatt válaszd a megfelelő sorbarendezést.
e. Jelöld ki az első oszlopot és Home -> Group by opciót használd így:
f. Add column -> Custom column opcióval kell egy új oszlopot beszúrni.
g. Az új oszlop jobb sarkában lévő ikonra kattints és válaszd az Extract values opciót.
h. Add meg az értékek közötti elválasztó jelet.
i. Töröld a felesleges középső oszlopot. Jobb klikk rajta és Remove.
j, Jelöld ki az első oszlopot és rendezd ABC sorrendbe ha szükséges.
k. Végül Home menűben a Close & Load gomb alatt válaszd a Close & Load to opciót és add meg hol jelenjen meg az eredmény.
Ha frissíteni kell ezt lekérdezést, akkor pl. a Data fülön a Refresh All-al tudod megtenni.
üdv.
-
Delila_1
veterán
Makróval:
Sub Vesszo()
Dim sor As Long
sor = 1
Do While Cells(sor, 1) > ""
If Cells(sor, "A") = Range("E1") Then
If Cells(1, "F") = "" Then
Cells(1, "F") = Cells(sor, "B")
Else: Cells(1, "F") = Cells(1, "F") & ", " & Cells(sor, "B")
End If
End If
If Cells(sor, "A") = Range("E2") Then
If Cells(2, "F") = "" Then
Cells(2, "F") = Cells(sor, "B")
Else: Cells(2, "F") = Cells(2, "F") & ", " & Cells(sor, "B")
End If
End If
sor = sor + 1
Loop
End SubA csatolt képen nem látszanak a sorszámok.
Ha az adatok nem az első sorban kezdődnek, a sor=1 sorban az 1 helyett a kezdő sorszámot add meg.
A két feltételnél is a Cells(1,"F") és aCells(2,"F")hivatkozásokat, no meg a Range("E1") és Range("E2")-t kell átírnod. -
Fferi50
Topikgazda
Szia!
"Esetleg még azt hogy a keresés beírásakor oda is ugorjon. ( több ezer sornál gyorsabb lenne )"
Ezt hogyan gondolod? Ha talál három egyezőt, mindháromra nem tud ugrani egyszerre. Vagy egyesével ugrál és megvárja, hogy csinálj vele valamit, vagy a legelsőre esetleg a legutolsó találatra tud ugrani.
Az ugrás maga:Rng.Activate
mondjuk ez elé:Rng.Interior.Color=vbYellow ' sárgára színezi a cellátÜdv.
-
Mutt
senior tag
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
-
Mutt
senior tag
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 -
Mutt
senior tag
Szia,
Az
.Offset(, 1) =részben a vessző után 1-es azt jelenti, hogy egy oszloppal mindig menjen jobbra a kiiratás, ha.Offset(1) =-re cseréled akkor a következő sorra fog ugrani.Sub ChickatAH()
Dim rng As Range, Lstrw As Long, c As Range
Dim SpltRng As Range
Dim i As Integer
Dim Orig As Variant
Dim txt As String
Lstrw = Cells(Rows.Count, "A").End(xlUp).Row
Set rng = Range("A2:A" & Lstrw)
Set kimenet = Sheets.Add 'új lapon legyen az eredmény
For Each c In rng.Cells
'Set SpltRng = c.Offset(, 1) 'felesleges
'txt = SpltRng.Value 'felesleges változóátadás
'Orig = Split(txt, " ") 'nem szököz alapján szabdalunk
Orig = Split(c, ";")
For i = 0 To UBound(Orig)
'Cells(Rows.Count, "D").End(xlUp).Offset(1) = c 'D oszlop üres sorába kiírja az eredeti értéket, nem kell?
'Cells(Rows.Count, "D").End(xlUp).Offset(, 1) = Orig(i) 'az offset(,1) mindig a következő oszlopba ugrik, nem ez kell
kimenet.Cells(Rows.Count, "D").End(xlUp).Offset(1) = Trim(Orig(i)) 'felesleges szóköztől megszabadulunk
Next i
Next c
End Subüdv
-
Mutt
senior tag
Szia,
B1-ben ez a képlet felszabdalja az A1 cella tartalmát:
=HA(SOROK(B$1:B1)-1>HOSSZ($A$1)-HOSSZ(HELYETTE($A$1;";";""));"";KIMETSZ(KÖZÉP($A$1;HAHIBA(SZÖVEG.TALÁL("@";HELYETTE($A$1;";";"@";SOROK(B$1:B1)-1));0)+1;HAHIBA(SZÖVEG.TALÁL("@";HELYETTE($A$1;";";"@";SOROK(B$1:B1)));HOSSZ($A$1)+1)-HAHIBA(SZÖVEG.TALÁL("@";HELYETTE($A$1;";";"@";SOROK(B$1:B1)-1));0)-1)))
Power Query-ben az oszlop felosztása esetén pedig megadhatod, hogy a kimenet sorokba legyen rendezve.
üdv
-
lappy
őstag
Szia!
"ahol vagy számok vannak vagy 0" miért a 0 nem szám?!
Amúgy a lehetőségek:
az egyik hogy szűrést teszel az oszlopokra- szűrés "0" kivéve- másol- beilleszt
vagy
egy ha függvénnyel vizsgálod hogy a g értékét és újra szűrés kell majd
vagy
közvetlen szűrés és megadod neki hogy hova tegye az eredményt -
Fferi50
Topikgazda
Szia!
Ha kérdés nélküli felülírást szeretnél, akkor
Application.DisplayAlerts = False a makró elejére és
Application.DisplayAlerts = True a makró végére.A kihagyáshoz:
LocalFileName = "C:\temp\" & Evaluate("TRIM(RIGHT(SUBSTITUTE(""" & c & """,""/"",REPT("" "",1000)),1000))")
B=Dir(LocalFileName)=""
If B Then B = True ThenDownloadFile(UrlFileName:=URL, _
DestinationFileName:=LocalFileName, _
Overwrite:=PromptUser, _
ErrorText:=ErrorText)
End ifÜdv.
-
lcdtv
tag
Válaszolok is ha valakinek szüksége lenne rá.
Option Explicit
Public Enum DownloadFileDisposition
OverwriteKill = 0
OverwriteRecycle = 1
DoNotOverwrite = 2
PromptUser = 3
End Enum
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Windows API functions, constants,and types.
' Used for RecycleFile.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Declare Function SHFileOperation Lib "shell32.dll" Alias _
"SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
Private Declare Function PathIsNetworkPath Lib "shlwapi.dll" _
Alias "PathIsNetworkPathA" ( _
ByVal pszPath As String) As Long
Private Declare Function GetSystemDirectory Lib "kernel32" _
Alias "GetSystemDirectoryA" ( _
ByVal lpBuffer As String, _
ByVal nSize As Long) As Long
Private Declare Function SHEmptyRecycleBin _
Lib "shell32" Alias "SHEmptyRecycleBinA" _
(ByVal hwnd As Long, _
ByVal pszRootPath As String, _
ByVal dwFlags As Long) As Long
Private Const FO_DELETE = &H3
Private Const FOF_ALLOWUNDO = &H40
Private Const FOF_NOCONFIRMATION = &H10
Private Const MAX_PATH As Long = 260
Private Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Boolean
hNameMappings As Long
lpszProgressTitle As String
End Type
'''''''''''''''''''''''''''
' Download API function.
''''''''''''''''''''''''''''''''''''''
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
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' DownloadFile
' This downloads a file from a URL to a local filename.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function DownloadFile(UrlFileName As String, _
DestinationFileName As String, _
Overwrite As DownloadFileDisposition, _
ErrorText As String) As Boolean
Dim Disp As DownloadFileDisposition
Dim Res As VbMsgBoxResult
Dim B As Boolean
Dim S As String
Dim L As Long
ErrorText = vbNullString
If Dir(DestinationFileName, vbNormal) <> vbNullString Then
Select Case Overwrite
Case OverwriteKill
On Error Resume Next
Err.Clear
Kill DestinationFileName
If Err.Number <> 0 Then
ErrorText = "Error Kill'ing file '" & DestinationFileName & "'." & vbCrLf & Err.Description
DownloadFile = False
Exit Function
End If
Case OverwriteRecycle
On Error Resume Next
Err.Clear
B = RecycleFileOrFolder(DestinationFileName)
If B = False Then
ErrorText = "Error Recycle'ing file '" & DestinationFileName & "." & vbCrLf & Err.Description
DownloadFile = False
Exit Function
End If
Case DoNotOverwrite
DownloadFile = False
ErrorText = "File '" & DestinationFileName & "' exists and disposition is set to DoNotOverwrite."
Exit Function
'Case PromptUser
Case Else
S = "The destination file '" & DestinationFileName & "' already exists." & vbCrLf & _
"Do you want to overwrite the existing file?"
Res = MsgBox(S, vbYesNo, "Download File")
If Res = vbNo Then
ErrorText = "User selected not to overwrite existing file."
DownloadFile = False
Exit Function
End If
B = RecycleFileOrFolder(DestinationFileName)
If B = False Then
ErrorText = "Error Recycle'ing file '" & DestinationFileName & "." & vbCrLf & Err.Description
DownloadFile = False
Exit Function
End If
End Select
End If
L = URLDownloadToFile(0&, UrlFileName, DestinationFileName, 0&, 0&)
If L = 0 Then
DownloadFile = True
Else
ErrorText = "Buffer length invalid or not enough memory."
DownloadFile = False
End If
End Function
Private Function RecycleFileOrFolder(FileSpec As String) As Boolean
Dim FileOperation As SHFILEOPSTRUCT
Dim lReturn As Long
If (Dir(FileSpec, vbNormal) = vbNullString) And _
(Dir(FileSpec, vbDirectory) = vbNullString) Then
RecycleFileOrFolder = True
Exit Function
End If
With FileOperation
.wFunc = FO_DELETE
.pFrom = FileSpec
.fFlags = FOF_ALLOWUNDO
' Or
.fFlags = FOF_ALLOWUNDO + FOF_NOCONFIRMATION
End With
lReturn = SHFileOperation(FileOperation)
If lReturn = 0 Then
RecycleFileOrFolder = True
Else
RecycleFileOrFolder = False
End If
End Function
Sub example()
Dim URL As String
Dim LocalFileName As String
Dim B As Boolean
Dim ErrorText As String
Dim c As Range
For Each c In Columns("K:L").SpecialCells(xlCellTypeConstants, 23)
URL = c
LocalFileName = "C:\temp\" & Evaluate("TRIM(RIGHT(SUBSTITUTE(""" & c & """,""/"",REPT("" "",1000)),1000))")
B = DownloadFile(UrlFileName:=URL, _
DestinationFileName:=LocalFileName, _
Overwrite:=PromptUser, _
ErrorText:=ErrorText)
If B = True Then
Debug.Print "Download successful"
Else
Debug.Print "Download unsuccessful: " & ErrorText
End If
Next c
End Sub
Új hozzászólás Aktív témák
Hirdetés
Fferi50
- Assassin's Creed Shadows Collector's Edition PC
- Bitdefender Total Security 3év/3eszköz! - Tökéletes védelem, Most kedvező áron!
- Windows, Office licencek kedvező áron, egyenesen a Microsoft-tól - Automata kézbesítés utalással is!
- Windows 10/11 Home/Pro , Office 2024 kulcsok
- Adobe Előfizetések - Adobe Creative Cloud All Apps - 12 Hónap - NYÁRI AKCIÓ!
- ÁRGARANCIA!Épített KomPhone Ryzen 9 5900X 16/32/64GB RAM RTX 5070 12GB GAMER PC termékbeszámítással
- Csere-Beszámítás! Xbox One X 1TB Játékkonzol Olvass! Model 1787
- Creative Sound BlasterX G5 (70SB170000000) (Sound Blaster) (DAC)
- Új Apple iPhone 16 Pro 128GB, Kártyafüggetlen, 3 Év Garanciával
- ÁRGARANCIA!Épített KomPhone i7 14700KF 32/64GB RAM RTX 4070 Ti Super GAMER PC termékbeszámítással
Állásajánlatok
Cég: CAMERA-PRO Hungary Kft
Város: Budapest
Cég: Promenade Publishing House Kft.
Város: Budapest