-
Fototrend
A Microsoft Excel topic célja segítséget kérni és nyújtani Excellel kapcsolatos problémákra.
Kérdés felvetése előtt olvasd el, ha még nem tetted.
Új hozzászólás Aktív témák
-
-
zhari
csendes tag
Ebben esetleg tud valaki segíteni?
Szerintem ezekkel a sorokkal van baj:
x(i, 9) = objFolder.GetDetailsOf(objFolderItem, 9)
x(i, 10) = objFolder.GetDetailsOf(objFolderItem, 10)Lehet ezek csak korábbi Excel verzióban működnek?
AZ új már máshol tárolja szerzőt és az utolsó módosítót? -
zhari
csendes tag
válasz
Fferi50
#26648
üzenetére
Köszi.
Ezt találtam még a neten de nem akar működni a szerző és az tulaj bejegyzés kinyerése. Meg tudnátok nézni h mi baja lehet?
Előre is köszi
Option Explicit
Public x()
Public i As Long
Public objShell, objFolder, objFolderItem
Public FSO, oFolder, Fil
Sub MainExtractData()
Dim NewSht As Worksheet
Dim MainFolderName As String
Dim TimeLimit As Long, StartTime As Double
ReDim x(1 To 65536, 1 To 11)
Set objShell = CreateObject("Shell.Application")
TimeLimit = Application.InputBox("Please enter the maximum time that you wish this code to run for in minutes" & vbNewLine & vbNewLine & _
"Leave this at zero for unlimited runtime", "Time Check box", 0)
StartTime = Timer
Application.ScreenUpdating = False
MainFolderName = BrowseForFolder()
Set NewSht = ThisWorkbook.Sheets.Add
x(1, 1) = "Path"
x(1, 2) = "File Name"
x(1, 3) = "Last Accessed"
x(1, 4) = "Last Modified"
x(1, 5) = "Created"
x(1, 6) = "Type"
x(1, 7) = "Size"
x(1, 8) = "Owner"
x(1, 9) = "Author"
x(1, 10) = "Title"
x(1, 11) = "Comments"
i = 1
Set FSO = CreateObject("scripting.FileSystemObject")
Set oFolder = FSO.GetFolder(MainFolderName)
'error handling to stop the obscure error that occurs at time when retrieving DateLastAccessed
On Error Resume Next
For Each Fil In oFolder.Files
Set objFolder = objShell.Namespace(oFolder.Path)
Set objFolderItem = objFolder.ParseName(Fil.Name)
i = i + 1
If i Mod 20 = 0 And TimeLimit <> 0 And Timer > (TimeLimit * 60 + StartTime) Then
GoTo FastExit
End If
If i Mod 50 = 0 Then
Application.StatusBar = "Processing File " & i
DoEvents
End If
x(i, 1) = oFolder.Path
x(i, 2) = Fil.Name
x(i, 3) = Fil.DateLastAccessed
x(i, 4) = Fil.DateLastModified
x(i, 5) = Fil.DateCreated
x(i, 6) = Fil.Type
x(i, 7) = Fil.Size
x(i, 8) = objFolder.GetDetailsOf(objFolderItem, 8)
x(i, 9) = objFolder.GetDetailsOf(objFolderItem, 9)
x(i, 10) = objFolder.GetDetailsOf(objFolderItem, 10)
x(i, 11) = objFolder.GetDetailsOf(objFolderItem, 14)
Next
'Get subdirectories
If TimeLimit = 0 Then
Call RecursiveFolder(oFolder, 0)
Else
If Timer < (TimeLimit * 60 + StartTime) Then Call RecursiveFolder(oFolder, TimeLimit * 60 + StartTime)
End If
FastExit:
Range("A:K") = x
If i < 65535 Then Range(Cells(i + 1, "A"), Cells(65536, "A")).EntireRow.Delete
Range("A:K").WrapText = False
Range("A:K").EntireColumn.AutoFit
Range("1:1").Font.Bold = True
Rows("2:2").Select
ActiveWindow.FreezePanes = True
Range("a1").Activate
Set FSO = Nothing
Set objShell = Nothing
Set oFolder = Nothing
Set objFolder = Nothing
Set objFolderItem = Nothing
Set Fil = Nothing
Application.StatusBar = ""
Application.ScreenUpdating = True
End Sub
Sub RecursiveFolder(xFolder, TimeTest As Long)
Dim SubFld
For Each SubFld In xFolder.Subfolders
Set oFolder = FSO.GetFolder(SubFld)
Set objFolder = objShell.Namespace(SubFld.Path)
For Each Fil In SubFld.Files
Set objFolder = objShell.Namespace(oFolder.Path)
'Problem with objFolder at times
If Not objFolder Is Nothing Then
Set objFolderItem = objFolder.ParseName(Fil.Name)
i = i + 1
If i Mod 20 = 0 And TimeTest <> 0 And Timer > TimeTest Then
Exit Sub
End If
If i Mod 50 = 0 Then
Application.StatusBar = "Processing File " & i
DoEvents
End If
x(i, 1) = SubFld.Path
x(i, 2) = Fil.Name
x(i, 3) = Fil.DateLastAccessed
x(i, 4) = Fil.DateLastModified
x(i, 5) = Fil.DateCreated
x(i, 6) = Fil.Type
x(i, 7) = Fil.Size
x(i, 8) = objFolder.GetDetailsOf(objFolderItem, 8)
x(i, 9) = objFolder.GetDetailsOf(objFolderItem, 9)
x(i, 10) = objFolder.GetDetailsOf(objFolderItem, 10)
x(i, 11) = objFolder.GetDetailsOf(objFolderItem, 14)
Debug.Print x(i, 1), x(i, 2), x(i, 11)
Else
Debug.Print Fil.Path & " " & Fil.Name
End If
Next
Call RecursiveFolder(SubFld, TimeTest)
Next
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level
Dim ShellApp As Object
'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
'Destroy the Shell Application
Set ShellApp = Nothing
'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function -
zhari
csendes tag
Sziasztok!
Olyan makróra lenne szükségem ami egy adott mappa (és almappái?) összes Word, Excel (és ha lehet pdf) fájljának a nevét felsorolja egy Excel oszlopban.
Közben meglett de iderakom hátha másvalaki is tudja használni:
Szép napot.
Sub ListAllFiles()
Dim fs As FileSearch, ws As Worksheet, i As Long
Set fs = Application.FileSearch
With fs
.SearchSubFolders = False ' set to true if you want sub-folders included
.FileType = msoFileTypeAllFiles 'can modify to just Excel files eg with msoFileTypeExcelWorkbooks
.LookIn = "C:\" 'modify this to where you want to serach
If .Execute > 0 Then
Set ws = Worksheets.Add
For i = 1 To .FoundFiles.Count
ws.Cells(i, 1) = .FoundFiles(i)
Next
Else
MsgBox "No files found"
End If
End With
End Sub -
#25956
zhari
csendes tag
Chesterfield
#25955
zhari
csendes tag
válasz
Chesterfield
#25955
üzenetére
Vízszintes igazítás a kijelölés közepére?
-
zhari
csendes tag
-
zhari
csendes tag
Ha a munka1 munkalap A oszlopán vannak az adott dátumok, a munka2 munkalap A oszlopán periódus kezdő, B oszlopán a periódus záró dátumai C oszlopán a periódusok nevei. Ha a periódusok fedhetik egymást és egy dátum több periódusban is szerepelhet, hogy gyűjtenétek össze, hogy egyes munka1 A oszlop dátumai mely periódusokba esnek bele. Hozzászólásokat előre köszönöm.
-
zhari
csendes tag
Sziasztok!
Egy adott mappában lévő Excel táblák képlet számítási beállítását szeretném makróval átállítani automatikusra.
Az addig oké, hogy makrót futtatok egy adott mappa összes xls-én. De hogy tudom a képlet újra számítást automatikusra állítani?
Sub LoopThroughFiles()FolderName = "C:\...\"
If Right(FolderName, 1) <> Application.PathSeparator Then FolderName = FolderName & Application.PathSeparator
Fname = Dir(FolderName & "*.xls")'loop through the files
Do While Len(Fname)With Workbooks.Open(FolderName & Fname)
' here comes the code for the operations on every file the code finds
'HERE if you want to execute the second macro for every file in the loop
'ide kéne a beállítás
End With
' go to the next file in the folder
Fname = DirLoop
End Sub
-
zhari
csendes tag
válasz
Delila_1
#22442
üzenetére
Szeretnék egy olyan makrót ami:
A lista nevű munkalap A1:D1-t átmásolja a kalkulátor munkalap B2:B5-jébe (transzponálva) , utána a kapott eredményt ( kalkulátor O6-ból és R6-ból) a lista E1 és F1-be másolja. Majd a lista munkalap A2:D2 tartományát másolja a B2:B5-be , utána a kapott eredményt ( kalkulátor O6-ból és R6-ból) a lista E2 és F2.be másolja. Majd a lista munkalap A3:D3 .....
Előre is köszönöttel(Jópofa dolgok ezek a smiley-k, de remélem így már nem alakítja át őket.)
-
zhari
csendes tag
Szeretnék egy olyan makrót ami:
A lista nevű munkalap A1
1-t átmásolja a kalkulátor munkalap B2
5-jébe (transzponálva) , utána a kapott eredményt ( kalkulátor O6-ból és R6-ból) a lista E1 és F1-be másolja. Majd a lista munkalap A22 tartományát másolja a B25-be , utána a kapott eredményt ( kalkulátor O6-ból és R6-ból) a lista E2 és F2.be másolja. Majd a lista munkalap A33 .....Előre is köszönöttel
-
zhari
csendes tag
válasz
Delila_1
#21879
üzenetére
Köszönöm. Szuperül működik.
Másolás résszel még gondban vagyok kb így nézne ki szerintem, de nem jó a beillesztésnél:
...
Sheets("Munka1").Select
Range("A1:L27").Select
Selection.Copy
ActiveWorkbook.Save
ActiveWindow.Close
Windows("02.xlsm").Activate 'gyűjtő füzet
gy_usor = Range("A65536").End(xlUp).Row 'Gyűjtő füzet alsó sora
Cells(gy_usor, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues
.... -
zhari
csendes tag
Sziasztok!
Végső célom az, hogy egy adott mappa almappáiból meghatározott nevű "cica_*.xlsx"-ek (* természetesen változik) állandó munkalapnevű (munka1) lapokról adott tartományokat egy új táblába egymás alá szeretnék másolni.
Van pár elvileg működő script amiket szeretnék egyesíteni, de nem jön össze.Sub makrófuttatás_almappákban()
Dim lCount As Long
Dim wbResults As Workbook
Dim wbCodeBook As WorkbookApplication.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = FalseOn Error Resume Next
Set wbCodeBook = ThisWorkbook
With Application.FileSearch
.NewSearch
'Change path to suit
.LookIn = "C:\...\egyéb\makrók\teszt"
.FileType = msoFileTypeExcelWorkbooks
.SearchSubFolders = True
'Optional filter with wildcard
'.Filename = "cica*.xls"
If .Execute > 0 Then 'Workbooks in folder
For lCount = 1 To .FoundFiles.Count 'Loop through all
'Open Workbook x and Set a Workbook variable to it
Set wbResults = Workbooks.Open(filename:=.FoundFiles(lCount), UpdateLinks:=0)'DO YOUR CODE HERE
Range("A1").Select
ActiveCell.FormulaR1C1 = "=2"wbResults.Close savechanges:=False
Next lCount
End If
End With
On Error GoTo 0
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
MsgBox "kész"
End SubA fentivel az a bajom, hogy nem tudom meghatározni, hogy milyen nevű táblákkal dolgozzon és mintha nem jó táblákon indítaná a makrót.
Egy másik script ugyanerre:
Sub makrófuttatás_almappákban()
Dim folderPath As String
Dim filename As String
Dim wb As WorkbookfolderPath = "C:\...\egyéb\makrók\teszt" 'change to suit
If Right(folderPath, 1) <> "" Then folderPath = folderPath + ""
filename = Dir(folderPath & "cica2*.xls")
Do While filename <> ""
Application.ScreenUpdating = False
Set wb = Workbooks.Open(folderPath & filename)'Call a subroutine here to operate on the just-opened workbook
Range("A1").Select
ActiveCell.FormulaR1C1 = "=2"
filename = Dir
Loop
Application.ScreenUpdating = True
MsgBox "kész", vbInformation
End SubA fentiek valamelyikét szeretném egyesíteni a következő scripptel.
Sub Fésü()
Const utvonal = "C:\...\egyéb\makrók\teszt" 'Ezt írd át arra a mappára, ahol az xls-eid vannak
Dim FN As String, WB As WorkbookChDir utvonal
FN = Dir(utvonal & "D01_*.xls", vbNormal)
Do
If FN <> "." And FN <> ".." Then
Workbooks.Open Filename:=FN
usor = Range("A65536").End(xlUp).Row 'Behívott füzet alsó soraWindows("02.xlsx").Activate
gy_usor = Range("A65536").End(xlUp).Row 'Gyűjtő füzet alsó soraWindows(FN).Activate 'Behívott füzet
Range(Cells(1, 1), Cells(usor, 12)).Copy 'A oszlop (1:4)Windows("02.xlsx").Activate 'Gyűjtő füzet
Cells(gy_usor, 1).Select
ActiveSheet.Paste
Windows(FN).Activate 'Behívott füzetActiveWorkbook.Save
ActiveWindow.Close
End If
FN = Dir()
Loop Until FN = ""
End SubRemélem érthető volt a problémám. Minden hozzászólást szívesen fogadok.
-
zhari
csendes tag
Szeretnék egy olyan macrót mely megnyitja az adott elérési út összes almappájából (C:\...\mappanév ) az összes aaa_yyyy.yy.yy.xlsx (y változik, aaa_ állandó) tábláját és ezen táblák minden "Munka1" nevű munkalapok L1 celláit és A4:L14 tartományait egymás alá másolja.
Tehát az első L1 menjen A1-be és az A4-L14 menjen B1-M12-be.
Második tábla L1 cellája A13-ba és az A4-L14 menjen B13-M24-be.Szép napot.
-
#20655
zhari
csendes tag
kőbaltazár
#20627
zhari
csendes tag
válasz
kőbaltazár
#20627
üzenetére
Esetleg próbáld ki =cella("védett"
függvényt egy segéd munkalapon. -
zhari
csendes tag
Szeretnék egy makrót, ami kitöltött word formanyomtatványokból előre meghatározott helyekről kimásol adatokat egy Excelbe. Biztos volt már hasonló kérdés, de nem találok rá választ. Előre is köszönöm a hozzászólásokat.
(Tehát vagy egy mappám amiben van 500 db word amik csak egy-egy dologban térnek el ugyanazokon a helyeken, ezeket a változókat szeretném egy excelbe egymás alá másoltatni.) -
zhari
csendes tag
Sziasztok!
Abban kérném a segítségeteket, hogy a hivatkozott jól működő email küldő makrót be lehet állítani, hogy az Outlookba felcsatolt két postafiókból melyikből küldje ki. Azaz melyik postafiók legyen az email küldője. Sajnos ha alapértelmezett fióknak veszem a kívánt fiókot (Outlookban) akkor nem működik.
Remélem érthető volt a kínom. -
zhari
csendes tag
-
zhari
csendes tag
Sziasztok!
Kerestem a korábbi hozzászólások között, de nem találtam megfelelőt.
Egy olyan makróra lenne szükségem ami megnyit annyi darab új munkalapot ahány cella töltött az aktív munkalap A oszlopában (kb 110) és elnevezi a cella értéke alapján az új munkalapot, Továbbá beírja ezt a tartalmat az új munkalap A1 cellájába.
Remélem érthető volt. Előre is köszönöm a segítséget.
-
-
zhari
csendes tag
Üdv!
Segítségeteket szeretném kérni egy makró írásában.
Azt kellene tudnia, hogy egy adott mappából megnyit minden excel dokumentumot és minden munkalapot összemásol egy dokumentumba. Tehát van 30 db xls. (különböző munkalapnevekkel) ebből kellene a 30 munkalapot egy .xls-be összemásolnia. -
zhari
csendes tag
Sziasztok!
A következő két makrót szeretném összekombinálni egy működő macróvá. A cél az, hogy egy mappa minden Excel tábláját megnyissa és belemásolja (és mentse) az éppen aktív munkalapot.
eddig ezeket találtam:
Dim fs As FileSearch
Dim i As Integer
Dim wbk As WorkbookSet fs = Application.FileSearch
With fs
.LookIn = ThisWorkbook.Path 'ide kell a táblákat tartalmazó mappa útvonala?
.FileName = "*.xls"
For i = 1 to .Execute()
Set wbk = Workbooks.Open(.FoundFiles(i))
' beillesztő makrót kb ide másolnám
wbk.Close(SaveChanges:=True)
Next i
End With
---------------------------------------------------------------------------------------------------------------------
munkalap másolás:Dim sourceSheet As Worksheet
Dim destSheet As Worksheet'' copy from the source
Workbooks.Open Filename:="c:\source.xls"
Set sourceSheet = Worksheets("source")
sourceSheet.Activate
sourceSheet.Cells.Select
Selection.Copy'' paste to the destination
Workbooks.Open Filename:="c:\destination.xls"
Set destSheet = Worksheets("dest")
destSheet.Activate
destSheet.Cells.Select
destSheet.Paste'' save & close
ActiveWorkbook.Save
ActiveWorkbook.Close
-------------------------------------------------------------------------------------
lelkesen fogadok minden segítséget... -
zhari
csendes tag
90%-ban sikerült. Pár módosítással:
B oszlopból szedi a címeket. D-E oszlopokból a csatolmányokat.
Abban tudnátok segíteni, hogy CC-be tegye a C oszlopban szereplő mail címet?Sub email_kuld()
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range, FileCell As Range, rng As RangeWith Application
.EnableEvents = False
.ScreenUpdating = False
End WithSet sh = Sheets("lista") 'munkalap neve
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
Set rng = sh.Cells(cell.Row, 1).Range("D1:E1") 'D-E oszlopig a csatolmányok. Bármi lehet.ok
If cell.Value Like "?*@?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)With OutMail
.To = cell.Value
.cc = "" 'CC-ket a C oszlopból kellene hivatkozni
.Subject = "teszt tárgya " & cell.Offset(0, -1).Value & " 2013.01.02 riport" ' Tárgyat frissíteni.ok
.Body = "Tisztelt " & cell.Offset(0, -1).Value & "!"For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell.Send 'Or use Display.
End WithSet OutMail = Nothing
End If
Next cellSet OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
MsgBox "E-mailek elküldve."
End Sub -
zhari
csendes tag
válasz
Pityke78
#14693
üzenetére
Úgy csinálnám, hogy ha számok az A oszlopban vannak akkor a B segéd oszlopba a következő képletet másolnám: =HA(VAGY(A1<=$C$1;A1>=$D$1);"x";""). C1 be 1 D 1 be 500 írnék. Utána pivot táblával (jelentésszűrőbe a B oszlop) könnyen össszeszámoltathatod a C1 és D1 paraméter változtatgatásával. Remélem érthető.
-
zhari
csendes tag
Sziasztok!
Szükségem lenne egy makróra, ami a következőt csinálja. Van egy Excel táblám (kb 20 oszlop és 3000 sor) amit új különböző táblákká kellene vágnia az A oszlop szerint. A fejlécen kívül mondjuk 30 féle adatot tartalmaz az A oszlop, ebből csináljon 30 db új filét ami csak az adott adat sorait tartalmazza és nevezze úgy el, hogy az eredeti név + "_adott adat").
Mentheti ugyanabban a mappába mint ahol az eredeti dokumentum volt.
Segítséget előre is köszönöm. -
zhari
csendes tag
Sziasztok!
Az B oszlopban szereplő értékeket feltételes formázással beszíneztem, a hozzájuk tartozó (u.az a sor) megnevezéseket az A oszlopban is ugyanolyan színre szeretném színezni (dinamikusan). Ezt hogyan tudnám megoldani függvénnyel (ha nem lehet akkor makróval)?
Szép napot.
-
#11081
zhari
csendes tag
Fehér Mancs
#11072
zhari
csendes tag
válasz
Fehér Mancs
#11072
üzenetére
Szuper. Köszi
1-t átmásolja a kalkulátor munkalap B2
5-jébe (transzponálva) , utána a kapott eredményt ( kalkulátor O6-ból és R6-ból) a lista E1 és F1-be másolja. Majd a lista munkalap A2
függvényt egy segéd munkalapon.
Új hozzászólás Aktív témák
- sziku69: Szólánc.
- Bestbuy játékok
- Kellemes karácsonyi ünnepeket!
- Gitáros topic
- PlayStation 5
- Synology NAS
- Intel Dual Core 2000 felhasználók barátságos offolós topikja
- Boldog karácsonyt kíván a PROHARDVER!
- Steam topic
- Drága bluetooth tagek olcsóbb alternatívái (MiLi MiTag, LiTag, OTAG, stb.)
- További aktív témák...
- Akció! Csere-Beszámítás! Sony PS VR 2 Headset. Gari-2027-05-05
- Felsőkategóriás Gamer PC! Csere-Beszámítás! R9 9800X3D / RTX 5080 16GB / 32GB DDR5 / 2TB SSD!
- Azonnali készpénzes Microsoft XBOX Series S és Series X felvásárlás személyesen/csomagküldéssel
- Samsung Galaxy S23 Ultra - Green - 8GB /256GB - Újszerű állapot!
- Telefon felvásárlás!! Samsung Galaxy A13/Samsung Galaxy A33/Samsung Galaxy A53
Állásajánlatok
Cég: Laptopszaki Kft.
Város: Budapest
Cég: BroadBit Hungary Kft.
Város: Budakeszi