Adatok másolása fájlok között

Adatok másolása fájlok között
2018-03-08T14:32:44+01:00
2018-03-09T14:34:03+01:00
2022-10-15T21:41:37+02:00
Csongi940228
Sziasztok!

A feladatom a következő:

Adott 33 Excel file, mindegyiknek változó mennyiségű munkalapja. Az utolsó munkalap az összesítő, ami a többit összegzi egy fájlon belül. Ebben vannak sorok amiket törölnék, hogy a másolandó adattömb elérje a megfelelő formát, de miután kimásolta így, ne mentse, alakuljon vissza. Tehát a 33 összesítőt szeretném VBA val átmásolni egy 34. fileba (ez lehet az amivel a makrot futtatom, de praktikusabb lenne ha azon kívüli file lehetne), majd ott egy táblába kéne másolni, ahol a munkafüzetek összesítőinek értékeit egymás mellé kéne másolni, tehát minden munkafüzet egy külön oszlopot kapna.
Nekem meghaladja a képességeimet a dolog... Idáig jutottam. Kérlek segítsetek! Előre is köszönöm!

Sub nagy_betolto()


Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim eleres As String
Dim idomerlegmakro As String
Dim i As Integer, j As Integer
Dim c As Range
Dim oszlop As Range
Dim a As Integer
Dim Összesítő As String



eleres = Cells(1, 7)

Range(Cells(2, 1), Cells(100, 3)).Clear

Application.ScreenUpdating = False

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(eleres)

i = 1
j = 1
For Each objFile In objFolder.Files

Cells(i + 1, 1) = objFile.Name
Cells(i + 1, 2) = objFile.Path
a = Workbooks.Open(objFile.Path).Worksheets.Count

If Worksheets.Name = "Összesítő" Then Worsheets.Open


Rows(21).Delete shift:=x1up
Rows(22).Delete shift:=x1up
Rows(63).Delete shift:=x1up
Rows(64).Delete shift:=x1up
Rows(84).Delete shift:=x1up
Rows(85).Delete shift:=x1up
Rows(114).Delete shift:=x1up
Rows(115).Delete shift:=x1up
Rows(153).Delete shift:=x1up
Rows(154).Delete shift:=x1up
Rows(159).Delete shift:=x1up
Rows(160).Delete shift:=x1up
Rows(166).Delete shift:=x1up
Rows(167).Delete shift:=x1up
Rows(175).Delete shift:=x1up
Rows(176).Delete shift:=x1up
Rows(177).Delete shift:=x1up
Rows(178).Delete shift:=x1up
Rows(188).Delete shift:=x1up
Rows(189).Delete shift:=x1up
Rows(190).Delete shift:=x1up
Rows(192).Delete shift:=x1up

Range("E13:E171").Copy



Workbooks(idomerlegmakro).Sheets(4).Activate
Cells(1, j).PasteSpecial


Next objFile

j = j + 1

i = i + 1


Application.ScreenUpdating = True


MsgBox ("Nagybetöltő kész!")

End Sub
Mutasd a teljes hozzászólást!
Szia!

Ez a sor nem oké:

If Worksheets.Name = "Összesítő" Then Worsheets.Open
Kimaradt a worksheet indexe, illetve a worksheetnek nincs open metódusa, azt kiválasztani (select) tudod.

Miután a sortörléseket elvégezted, ez így - a fent leírtak végett - szintén nem jó:

Workbooks(idomerlegmakro).Sheets(4).Activate
Először aktiváld a workbookot, aztán válaszd ki a munkalapot.

Ha nem akarod menteni a forrás munkafüzetekben a módosításokat, akkor javaslom, hogy írd át úgy a kódot, hogy az összesítő munkalapok tartalmát egyben másolja át a vezérlő munkafüzetbe (azon belül egy másik munkalapra), és ott törölgesd, ami nem kell. Így nem történik módosítás a forrás munkafüzetben, és nem fog visszaszövegelni az excel, hogy mented-e... (bár ezt valószínűleg az Application-ben is lehet tiltani, de ezt passzolom, még nem csináltam)
Mutasd a teljes hozzászólást!

  • Köszi a segítséget  Amint tudom kipróbálom
    Mutasd a teljes hozzászólást!
  • Köszönöm a segítséget, végül ahogy javasoltad, a makró füzetbe másoltam be, így most szépen adott mappa fájljainak összesítő munkalapjainak adott sorait bemásolja a makrósba, majd a fájlok nevét is az oszlopok fölé másolja. Minden futtatásnál tisztítja maga előtt az utat.

    Nagyon köszönöm még egyszer!
    Itt a kód ami működik:

    Sub nagy_betolto()


    Dim objFSO As Object
    Dim objFolder As Object
    Dim objFile As Object
    Dim eleres As String
    Dim makro As String
    Dim i As Integer, j As Integer
    Dim c As Range
    Dim oszlop As Range
    Dim a As Integer
    Dim Összesítő As String
    Dim Adattér As String
    Dim makrolap As String


    eleres = Cells(1, 7)
    makro = ActiveWorkbook.Name
    Range(Cells(2, 1), Cells(100, 3)).Clear

    Sheets("Adattér").Select
    Range(Cells(2, 1), Cells(200, 40)).Clear

    Sheets("makrolap").Select

    Application.ScreenUpdating = False

    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFSO.GetFolder(eleres)

    i = 1
    j = 1
    For Each objFile In objFolder.Files

    Cells(i + 1, 1) = objFile.Name
    Cells(i + 1, 2) = objFile.Path
    Workbooks.Open (objFile.Path)

    Sheets("Összesítő").Select
    Application.CutCopyMode = False
    Range("E13:E191").Copy


    Workbooks(idomerlegmakro).Activate
    Sheets("Adattér").Select
    Cells(2, j).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    Application.CutCopyMode = False
    Workbooks(objFile.Name).Close

    Sheets("makrolap").Select



    j = j + 1
    i = i + 1

    Next objFile


    Application.ScreenUpdating = True


    Workbooks(makro).Activate

    Sheets("makrolap").Select
    Range("A2:A41").Select
    Selection.Copy
    ActiveWindow.SmallScroll Down:=-27
    Range("M1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Adattér").Select
    Range("A1").Select
    ActiveSheet.Paste

    Sheets("makrolap").Select
    Range("M1:AZ1").Clear


    MsgBox ("Nagybetöltő kész!")

    End Sub
    Mutasd a teljes hozzászólást!
Tetszett amit olvastál? Szeretnél a jövőben is értesülni a hasonló érdekességekről?
abcd