Új hozzászólás Aktív témák

• #38054 Mutt aktív tag lcdtv #38040

  Új Válasz 2018-05-16 23:05:46 #38054

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Mutt

  aktív tag

  válasz lcdtv #38040 üzenetére

  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

  A tanácsaimat ingyen adom. Ha nem tetszik, akkor kérlek ne kritizáld! / https://github.com/viszi/codes/tree/master/Excel

Új hozzászólás Aktív témák