Hozzászólások
-
Szia! Kiszedtem a duplázást, szépen dolgozik, csak az a baj, hogy nem egymás alá rakja a másolt adatokat, hanem egymásra, felülírja. Illetve nem tudom miért, de a célmunkalapon az ‘A19’ cellánál kezdi nem pedig az elején.
Sub Munka1() Dim wb As Workbook Set wb = ActiveWorkbook Dim directory As String, fileName As String, sheet As Worksheet directory = "D:\2019.08\" fileName = Dir(directory & "*.xlsx") Do While fileName <> "" Workbooks.Open fileName:=directory & fileName, ReadOnly:=True Range("A2:E" & ActiveSheet.UsedRange.Rows.Count).Copy Destination:=wb.Worksheets("Célmunkalap").Range("A" & wb.Worksheets("Célmunkalap").UsedRange.Rows.Count + 1) Workbooks(fileName).Close False fileName = Dir() Loop End SubÜdv!
Eddig eljutottam, de nem jól működik. Mi lehet a hiba? A másolt adatokat szépen egymás alá kellene folyamatosan írnia, de nem úgy csinálja.Sub Munka1()
Dim wb As Workbook
Set wb = ActiveWorkbook
Dim directory As String, fileName As String, sheet As Worksheet
directory = „D:\2019.08\”
fileName = Dir(directory & „*.xlsx”)
Do While fileName <> „”
Workbooks.Open fileName:=directory & fileName, ReadOnly:=True
Range(„A2:E” & ActiveSheet.UsedRange.Rows.Count).Copy Destination = _ wb.Worksheets(„Célmunkalap”).Range(„A” & wb.Worksheets(„Célmunkalap”).UsedRange.Rows.Count + 1)
Windows(„Órák.xlsm”).Activate
Range(„A” & wb.Worksheets(„Célmunkalap”).UsedRange.Rows.Count + 1).Select
ActiveSheet.Paste
Workbooks(fileName).Close
fileName = Dir()
Loop
End SubSzia! Nem az egész fájlt szeretném bemásolni, csak meghatározott oszlopokat. Jelen esetben az „a” oszlopból a személyeket, és a hozzájuk tartozó munkaidőket „r” oszlopból valamint a dátumot. Egymás alá. Ez a művelet havi szinten elvégzendő, minden naphoz két db xlsx fálj tartozik. Én makróra gondoltam. Közepes felhasználói szinten vagyok. A mellékelt fálj mutatja mire gondolok (elnagyolva).
Köszönettel Tibor
