-
GAMEPOD.hu
A Microsoft Excel topic célja segítséget kérni és nyújtani Excellel kapcsolatos problémákra.
Kérdés felvetése előtt olvasd el, ha még nem tetted.
Új hozzászólás Aktív témák
-
Delila_1
Topikgazda
válasz slashing #22169 üzenetére
[Sub it()
Dim cell As Range, usor As Long
Dim selectRange As Range
usor = Sheets("Munka1").Range("A" & Rows.Count).End(xlUp).Row
For Each cell In ActiveSheet.Range("A3:A" & usor)
If (cell.Value <> "") Then
If selectRange Is Nothing Then
Set selectRange = cell
Else
Set selectRange = Union(cell, selectRange)
End If
End If
Next cell
usor = Sheets("mega").Range("A" & Rows.Count).End(xlUp).Row + 1
selectRange.Copy
Sheets("mega").Range("A" & usor).PasteSpecial Paste:=xlPasteAll, Transpose:=True
End Sub[ Szerkesztve ]
Programozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.
-
Delila_1
Topikgazda
válasz slashing #22169 üzenetére
Az előbbi makró csak a megnyitott fájl adatainak a másolását oldotta meg. A mostaniban a fájlok megnyitása, és zárása is szerepel.
A Pathname változóban írd át az útvonalat. Nem érdemes az összefűzendő fájlokat és azt, amelyikben összefűzöd, azonos mappában tartani.
Sub ProcessFiles()
Dim Filename, Pathname As String, WBN As String
Dim wb As Workbook
WBN = ActiveWorkbook.Name
Pathname = "F:\Eadat\valami\"
Filename = Dir(Pathname & "*.xls")
Do While Filename <> ""
Set wb = Workbooks.Open(Pathname & Filename)
DoWork wb, WBN
wb.Close SaveChanges:=True
Filename = Dir()
Loop
End SubSub DoWork(wb As Workbook, WBN)
Dim usor As Long, cell As Range, selectRange As Range
With wb
usor = .Sheets("Munka1").Range("A" & Rows.Count).End(xlUp).Row
For Each cell In .Sheets(1).Range("A3:A" & usor)
If (cell.Value <> "") Then
If selectRange Is Nothing Then
Set selectRange = cell
Else
Set selectRange = Union(cell, selectRange)
End If
End If
Next cell
usor = Workbooks(WBN).Sheets("mega").Range("A" & Rows.Count).End(xlUp).Row + 1
selectRange.Copy
Workbooks(WBN).Sheets("mega").Range("A" & usor).PasteSpecial Paste:=xlPasteAll, Transpose:=True
End With
End SubProgramozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.
Új hozzászólás Aktív témák
- D1Rect: Nagy "hülyétkapokazapróktól" topik
- exHWSW - Értünk mindenhez IS
- Intel Core i5 / i7 / i9 "Alder Lake-Raptor Lake/Refresh" (LGA1700)
- mefistofeles: Miért így bizniszelsz?
- Mobil flották
- AMD GPU-k jövője - amit tudni vélünk
- Kormányok / autós szimulátorok topicja
- Színészek hangjait lopta el egy AI-cég
- Politika
- Kerékpárosok, bringások ide!
- További aktív témák...
- PC JÁTÉKOK (OLCSÓ STEAM, EA , UPLAY KULCSOK ÉS SOKMINDEN MÁS IS 100% GARANCIA )
- Eredeti Microsoft termékek - MEGA Akciók! Windows, Office Pro Plus, Project Pro, Visio Pro stb.
- Microsoft licencek KIVÉTELES ÁRON AZONNAL - UTALÁSSAL IS AUTOMATIKUS KÉZBESÍTÉS - Windows és Office
- Új, bontatlan World of Warcraft gyűjtői kiadások
- Warhammer Online - Age of Reckoning (DE) Collectors Box (Figurával!)
Állásajánlatok
Cég: Ozeki Kft.
Város: Debrecen
Cég: Promenade Publishing House Kft.
Város: Budapest