DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub birleştir()
Dim dosya As String, sonsat1 As Long, sonsat2 As Long
Dim sh As Worksheet
Range("B2:T" & Rows.Count).UnMerge
Range("B2:T" & Rows.Count).Clear
Application.ScreenUpdating = False
sonsat1 = Cells(Rows.Count, "B").End(xlUp).Row + 1
dosya = Dir(ThisWorkbook.Path & "\Kaynak\*.xls")
Do While dosya <> ""
Application.DisplayAlerts = False
If Workbooks.Open(ThisWorkbook.Path & "\Kaynak\" & dosya).ReadOnly = True Then
Workbooks(dosya).Close True
End If
Application.DisplayAlerts = True
' Set sh = Sheets("Sheet1")
set sh = Activesheet
sonsat2 = sh.Cells(Rows.Count, "B").End(xlUp).Row
ThisWorkbook.Activate
sh.Range("B1:T" & sonsat2).Copy
Range("B" & sonsat1).PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
Workbooks(dosya).Close False
sonsat1 = Cells(Rows.Count, "B").End(xlUp).Row + 1
Set sh = Nothing
dosya = Dir
Loop
Application.ScreenUpdating = True
MsgBox "Veriler aktarıldı." & vbLf & "evrengizlen@hotmail.com"
End Sub
Buyrun Dosya