|
Тема |
Re: Копиране на всички листове в един [re: BatiGogo] |
|
Автор |
musketeer (познай кой...) |
|
Публикувано | 03.03.17 05:32 |
|
|
BatiGogo, много благодаря за вниманието!
Ами аз все за ексел говоря/мисля и не ми минава и през ум, че може да не са екселски :)
Да, екселски, Офис 2010. Празни редове няма - това е експорт от ERP система. Всички листи са идентични по структура и без празни редове. Хедърите не ме притесняват, т.е. може да не се прескачат (1-ият ред във всеки лист).
Считам темата за полезна, а и най-малкото ми е 3 ден крадене на код от нета, искам да дам решението, до което стигнах. Работи перфектно, и решава за около 4 секунди работата на 3 човека за около 3 часа, или накратко 9 човекочаса (вкл. поправянето на неизбежните грешки при ръчна обработка).
Лошото е, че не виждам тагове за код тук... пробвам с пре
Sub CopyDataWithoutHeaders()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim shLast As Long
Dim CopyRng As Range
Dim StartRow As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Delete the sheet "RDBMergeSheet" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'Add a worksheet with the name "RDBMergeSheet"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"
'Fill in the start row
StartRow = 1
'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
'Find the last row with data on the DestSh and sh
Last = LastRow(DestSh)
shLast = LastRow(sh)
'If sh is not empty and if the last row >= StartRow copy the CopyRng
If shLast > 0 And shLast >= StartRow Then
'Set the range that you want to copy
Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))
'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If
'This example copies values/formats, if you only want to copy the
'values or want to copy everything look below example 1 on this page
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
End If
End If
Next
ExitTheSub:
Application.Goto DestSh.Cells(1)
'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
Променил съм само 'Fill in the start row
StartRow = 1 , което прави името невярно, но за мен е идеално :)
Това, разбира се не е мое творение, а на един изключително услужлив колега
Редактирано от musketeer на 03.03.17 05:35.
|
| |
|
|
|