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

• #38039 Mutt senior tag lcdtv #38037

  Új Válasz 2018-05-15 22:35:46 #38039

  Ú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

  senior tag

  válasz lcdtv #38037 üzenetére

  Próbáld meg ezt a javított makrót.

  Sub ttt()
Dim forraslap As Worksheet, cellap As Worksheet
Dim forrasfuzet As Workbook

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
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

'ha nincs még az új füzetben ilyen nevű lap, akkor létrehozzuk
If cellap Is Nothing Then
Set cellap = uj.Worksheets.Add
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
uj.SaveAs mappa & "eredmeny.xlsx"
uj.Close False
Next
MsgBox "Kész"

End Sub

• #38038 Mutt senior tag lcdtv #38037

  Új Válasz 2018-05-15 17:00:55 #38038

  Ú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

  senior tag

  válasz lcdtv #38037 üzenetére

  Szia,

  Erre lehetne használni a Power Query-t is.

  üdv

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