VBA kód átalakítása

VBA kód átalakítása
2021-09-14T10:10:43+02:00
2021-09-24T12:56:12+02:00
2022-10-15T21:25:39+02:00
naga004
Tisztelt Fórumtagok,

Egy szakmai kérdéssel fordulok hozzátok. Van egy macro-m amelynek az a feladata, hogy ugyanolyan szerkezetű, de eltérő adattartalmú Excel-táblákat összefűzzön egy db. nagy adatbázissá. Ehhez két paramétert kell megadni.:

• a táblákat tartalmazó mappa elérési útvonalát, illetve
• a táblák melyik oszlopának adatsorát figyelje.

Ezek az összefűzendő Excel-táblák nem tartalmaznak képletet, illetve hivatkozásokat csak szöveg és szám adatokat. Az adatokat a macro egy aktív munkalapról kimásolja, de egy másik elrejtett lappal nem foglalkozik. A folyamat egy gomb megnyomásával indul és egymás után nyitja meg a táblákat és másolja ki az adatokat és bezárja. Csak azt kérdezi minden bezárásnál, hogy mentse-e vagy ne. Amint a kattintok ugrik a következő táblára ameddig el nem éri az utolsót.

Abban kérném a segítségeteket, hogy ezt a macro-kódot hogyan lehet úgy átalakítani, hogy:

Az összefűzendő forrás Excel-táblákból van több mint 50db. Felépítését tekintve egy forrás Excel-tábla 32 munkalapszegélyt tartalmaz. Ebből 31-be töltenek adatokat manuálisan, a 32. oldal pedig összeadja az előző 31 oldal adatait (szumma).  Azaz a 32. oldal tartalmaz hivatkozást és képletet.

Ezért kérdésem, hogy a lenti kód általakítható-e úgy:

• az összefűzendő adatrész a régivel ellentétben csak egy sor lenne minden Excel tábla utolsó munkalapszegélyén (32.)
• a másolandó sor tartalmaz képleteket, de azt ne másolja át, hanem csak az értéket és a szöveget amit a képlet kiszámol.
• Illetve az átmásolandó sor munkalapszegélye (32.) az elrejtett lenne, tehát úgy fűzze össze, hogy ne az aktív lapról hanem az elrejtettről.

A VBA kód.:

Sub ShowFileList()

    Dim fs, f, f1, fc, s
    nev = ActiveWorkbook.Name

    folderspec = Worksheets("alap").Cells(3, 6)
    h = Worksheets("alap").Cells(4, 6)

    K = 2

    Sheets("osszes").Select

    Cells.Select
    Application.CutCopyMode = False
    Selection.ClearContents
    Sheets("alap").Select

    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(folderspec)
    Set fc = f.Files
    For Each f1 In fc

        s = folderspec & f1.Name
        Workbooks.Open Filename:=s
         Sheets(1).Select
        If Sheets(1).AutoFilterMode = True Then Selection.AutoFilter
        i = 2
        Do Until Cells(i, h) = ""
            i = i + 1
        Loop
        Rows("2:" & i - 1).Select
        Selection.Copy
        Windows(nev).Activate
        Sheets("osszes").Select
        Cells(K, 1).Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
        ActiveWindow.ActivateNext
        ActiveWorkbook.Close
        K = K + i - 2

    Next

    MsgBox "Finish"

End Sub

Válaszotok előre is köszönöm

Üdv.:
G
Mutasd a teljes hozzászólást!
Szia!

1. Nem tudom, miért pont a 3. sort szeretnéd kimásolni, amikor nem tudod előre, hanyadik sor lesz az, ami a feltételnek megfelel. Korábbi hozzászólásomban már írtam, hogy egy sor másolásához a
Rows(i-1).Copy a megfelelő. Sajnos ezt nem javítottam az előző hsz-ban.
2. Nem kell oda-vissza aktíválni a munkafüzeteket. Amikor megnyitunk egy munkafüzetet, az válik aktívvá, amikor bezárjuk, akkor az ami a nyitás előtt volt aktív.
Remélem ez már megfelelően fog működni:

Sub ShowFileList() Dim fs, f, f1, fc, s nev = ActiveWorkbook.Name folderspec = Worksheets("alap").Cells(3, 6) h = Worksheets("alap").Cells(4, 6) K = 2 Sheets("osszes").Select Cells.Select Application.CutCopyMode = False Selection.ClearContents Sheets("alap").Select Set fs = CreateObject("Scripting.FileSystemObject") Set f = fs.GetFolder(folderspec) Set fc = f.Files For Each f1 In fc s = folderspec & f1.Name Workbooks.Open Filename:=s 'Sheets(1).Select mivel nem az első lapról másolunk nem kell kiválasztani With Sheets("AD") If .AutoFilterMode = True Then .AutoFilter i = 2 Do Until .Cells(i, h) = "" i = i + 1 Loop .Rows(i - 1).Copy 'a konkrét sort másoljuk ki 'Selection.Copy ezért nem kell a sort kiválasztani End With Workbooks(nev).Sheets("osszes").Cells(K, 1).PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False 'ActiveWindow.ActivateNext ActiveWorkbook.Close K = K + 1 Next MsgBox "Finish" End Sub
(Az aposztróffal - ' - kezdődő sorok megjegyzések, nem számítanak be a makró futásába.)
Üdv.
Mutasd a teljes hozzászólást!

  • Szia!
    Csak néhány helyen kell változtatni rajta szerintem.
    Próbáld ki ezt:

    Sub ShowFileList() Dim fs, f, f1, fc, s nev = ActiveWorkbook.Name folderspec = Worksheets("alap").Cells(3, 6) h = Worksheets("alap").Cells(4, 6) K = 2 Sheets("osszes").Select Cells.Select Application.CutCopyMode = False Selection.ClearContents Sheets("alap").Select Set fs = CreateObject("Scripting.FileSystemObject") Set f = fs.GetFolder(folderspec) Set fc = f.Files For Each f1 In fc s = folderspec & f1.Name Workbooks.Open Filename:=s 'Sheets(1).Select mivel nem az első lapról másolunk nem kell kiválasztani If Sheets(32).AutoFilterMode = True Then Selection.AutoFilter i = 2 Do Until Cells(i, h) = "" i = i + 1 Loop Rows("2:" & i - 1).Copy 'a konkrét sort másoljuk ki 'Selection.Copy ezért nem kell a sort kiválasztani Windows(nev).Activate Sheets("osszes").Select Cells(K, 1).Select ActiveSheet.PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False ActiveWindow.ActivateNext ActiveWorkbook.Close K = K + i - 2 Next MsgBox "Finish" End Sub
    Egy dolog fontos: Valóban a 32-nek kell lennie az összesítő munkalapnak - mivel a munkalapok sorrendje megváltoztatható, ez sajnos nem garantálható. Ezért célszerűbb lenne az összesítő munkalapnak a nevét használni. A Sheeets(32) helyett pl a Sheets("osszesito") biztosan az összesítő munkalapot fogja használni - persze csak akkor, ha valóban így neveztétek el az összesítő munkalapot.
    Remélem műxik.
    Lenne a kód egyszerűsítésével kapcsolatban még pár észrevételem, de azt most elhagyom.
    Üdv.
    Mutasd a teljes hozzászólást!
  • megoldható.

    én nem látom, hogy hol megy végig a sheeteken a program, de nem gond, hogy csak 1 darabot nézzen meg.  neki az hogy rejtett nem rejtett nem számít, simán dolgozik a rejtettel is.

    a képlet helyett érték másolása: 
    az én számomra elnagyolt nagyon a kód, de én ezt a copy-paste cuccot elfelejteném, 
    itt fontos az aktivitás, tehát villódzik a képernyő, és folyamatosan ugrál a munkafüzetek, munkalapok között... lényeges a lassulás. 
    ez helyett:

    Rows("2:" & i - 1).Select Selection.Copy Windows(nev).Activate Sheets("osszes").Select Cells(K, 1).Select ActiveSheet.Paste Application.CutCopyMode = False ActiveWindow.ActivateNext
    én itt valami ilyesmit alkalmaznék:

    workbooks(célmunkafüzet).worksheets(célmunkalap).rows(célsor).value =workbooks(kiindulomunkafüzet).worksheets(kiindulomunkalap).rows(kiindulosor).value
    igy nem kell ugrálni és egy kicsit áttekinthetőbb... és a .value elméletileg csak az értéket másolja... 

    még egy dolog:
    ha jól sejtem ez a rész: 

    i = 2 Do Until Cells(i, h) = "" i = i + 1 Loop
    az utolsó sort keresi. 
    ez is egyszerűbb a 
    worksheets(ws_neve).cells(1,1).currentregion.rows.count-al. 
    ez visszaadja, hogy az a1es cellától, hány összefüggó sor van....
    Mutasd a teljes hozzászólást!
  • Szia,

    Köszönöm a gyors választ, teszteltem a csatolt kódot, de nem akar működni. Csatoltam az összefűző Excelt. Az összefűzendőket nem engedte csatolni, viszont azokban annyit változtattam a kód az összefűzendő táblákból nem a 32-es hanem a 33. "AD" nevű munkalapról másolja ki csak a 3. sort, de ez még nem működik. Ebben tudnál segíteni?

    Válaszod előre is köszönöm
    Üdv.:
    G
    Mutasd a teljes hozzászólást!
    Csatolt állomány
  • Szia!

     Az összefűzendőket nem engedte csatolni

    Milyen hibaüzenetet kaptál? Ha a debugra kattintasz a hibapanelen, akkor a VBA ablakban megmutatja, melyik sor okozza a hibát.
    Ezt kellene látnunk.
    Addig is próbálj ennyit változtatni:

    Windows(nev).Activate helyett Workbooks(nev).Activate

    mivel a nev változó a munkafüzet nevét tartalmazza és az nem feltétlenül egyezik az ablak nevével.
    Üdv.
    Mutasd a teljes hozzászólást!
  • Szia,

    Kipróbáltam, de nem műk. Csatoltam a debugger hibaüzijét. png-ben van látod?

    Üdv.:
    G
    Mutasd a teljes hozzászólást!
    Csatolt állomány
  • Szia!
    A következő sorok

    Sheets("osszes").Select Cells(K, 1).Select ActiveSheet.PasteSpecial Paste:=xlPasteValuess
    helyett

    Sheets("osszes").Cells(K, 1).PasteSpecial Paste:=xlPasteValues
    Üdv.
    Mutasd a teljes hozzászólást!
  • Szia,

    Kicseréltem lefutott, de nem olyan lett. Csatoltam a táblát és piros mezővel jelöltem amilyen lett. Zölddel hogy milyent szeretnék.

    Üdv.:
    G
    Mutasd a teljes hozzászólást!
    Csatolt állomány
  • Szia!
    Már csak a forrás munkalap szerkezetét kellene ismerni, legalább kép formában.
    A bizalmas adatokat (név, stb.) írd át lsz.
    Jó lenne a táblából legalább 8-10 sort látni.
    Valószínűleg a keresési feltétel nem megfelelő vagy a feladatot értettem félre.
    Üdv.
    Mutasd a teljes hozzászólást!
  • Szia,

    Küldöm a forrást. ebből van 80db

    Üdv.:
    G
    Mutasd a teljes hozzászólást!
  • Szia!
    Bocs, de az alap F4 cellában 8-as van, akkor az a H oszlopban fogja keresgélni a nem üres cellát. A mintában pedig csak az E oszlopig van adat ( gondolom, az élesben van tovább is).
    Ha az utolsó értékes adatra vagy kíváncsi, akkor  
    Range("H2").End(xlDown).Row az utolsó adatot tartalmazó cella sora.
    Továbbá ez:
    Rows("3:" & i - 1).Copy  
    nem egy sort másol, hanem a harmadiktól a végéig sorokat.
    Ha csak egy sort szeretnél másolni, akkor a te képleteddel 
    Rows(i-1).Copy
    Üdv.
    Mutasd a teljes hozzászólást!
  • Szia,

    Igen azt elrontottam a 8-as az 5-ös, most működik, viszont nem az elrejtett AD fülről másolja ki az adatokat, hanem az összesítőtől. Illetve csatoltam az összefűzőt ahol a sorok egy sor kihagyásával kerülnek egymás alá, lehet úgy hogy következetesen egymás alá kerüljenek, üres sorok nélkül?

    Válaszod előre is ksözönöm
    Üdv.:
    G
    Mutasd a teljes hozzászólást!
    Csatolt állomány
  • Szia!
    Nézd meg így lsz.

    Sub ShowFileList() Dim fs, f, f1, fc, s nev = ActiveWorkbook.Name folderspec = Worksheets("alap").Cells(3, 6) h = Worksheets("alap").Cells(4, 6) K = 2 Sheets("osszes").Select Cells.Select Application.CutCopyMode = False Selection.ClearContents Sheets("alap").Select Set fs = CreateObject("Scripting.FileSystemObject") Set f = fs.GetFolder(folderspec) Set fc = f.Files For Each f1 In fc s = folderspec & f1.Name Workbooks.Open Filename:=s 'Sheets(1).Select mivel nem az első lapról másolunk nem kell kiválasztani With Sheets("AD") If .AutoFilterMode = True Then .AutoFilter i = 2 Do Until .Cells(i, h) = "" i = i + 1 Loop .Rows("3:" & i - 1).Copy 'a konkrét sort másoljuk ki 'Selection.Copy ezért nem kell a sort kiválasztani End With Workbooks(nev).Activate Sheets("osszes").Cells(K, 1).PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False ActiveWindow.ActivateNext ActiveWorkbook.Close K = K + 1 Next MsgBox "Finish" End Sub
    Üdv.
    Mutasd a teljes hozzászólást!
  • Szia, leteszteltem, de ez a kód minden táblából csak az 1 sort másolja ki a 3. helyett és az utolsó táblában pedig mind az első hármat
    Mutasd a teljes hozzászólást!
    Csatolt állomány
  • Szia!

    1. Nem tudom, miért pont a 3. sort szeretnéd kimásolni, amikor nem tudod előre, hanyadik sor lesz az, ami a feltételnek megfelel. Korábbi hozzászólásomban már írtam, hogy egy sor másolásához a
    Rows(i-1).Copy a megfelelő. Sajnos ezt nem javítottam az előző hsz-ban.
    2. Nem kell oda-vissza aktíválni a munkafüzeteket. Amikor megnyitunk egy munkafüzetet, az válik aktívvá, amikor bezárjuk, akkor az ami a nyitás előtt volt aktív.
    Remélem ez már megfelelően fog működni:

    Sub ShowFileList() Dim fs, f, f1, fc, s nev = ActiveWorkbook.Name folderspec = Worksheets("alap").Cells(3, 6) h = Worksheets("alap").Cells(4, 6) K = 2 Sheets("osszes").Select Cells.Select Application.CutCopyMode = False Selection.ClearContents Sheets("alap").Select Set fs = CreateObject("Scripting.FileSystemObject") Set f = fs.GetFolder(folderspec) Set fc = f.Files For Each f1 In fc s = folderspec & f1.Name Workbooks.Open Filename:=s 'Sheets(1).Select mivel nem az első lapról másolunk nem kell kiválasztani With Sheets("AD") If .AutoFilterMode = True Then .AutoFilter i = 2 Do Until .Cells(i, h) = "" i = i + 1 Loop .Rows(i - 1).Copy 'a konkrét sort másoljuk ki 'Selection.Copy ezért nem kell a sort kiválasztani End With Workbooks(nev).Sheets("osszes").Cells(K, 1).PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False 'ActiveWindow.ActivateNext ActiveWorkbook.Close K = K + 1 Next MsgBox "Finish" End Sub
    (Az aposztróffal - ' - kezdődő sorok megjegyzések, nem számítanak be a makró futásába.)
    Üdv.
    Mutasd a teljes hozzászólást!
  • Szia,

    Köszönöm a kódot, de ez még mindig nem a 33. oldalról veszi az adatokat, hanem a 32. ről. Viszont összefűzi a táblákat, de behoz olyan adatokat amik nincsenek is benne a forrás táblába, azaz üres forrás táblában 0-kellene hoznia, de értéket vesz valahonnan. Ez mitől lehet?

    Csatoltam a táblát is

    Válaszod előre is köszönöm
    Üdv.:
    G
    Mutasd a teljes hozzászólást!
    Csatolt állomány
Tetszett amit olvastál? Szeretnél a jövőben is értesülni a hasonló érdekességekről?
abcd