[VBA ] excel分頁合併資料太長會出錯
因為需要將excel的所有分頁合併成一個
在網路上找到一支可以用的程式 在一般的短資料也確實沒有問題
但是當欄位裡面有長資料的時候就會發生錯誤
錯誤訊息顯示為
執行階段錯誤'1004':
應用程式或物件定義上的錯誤
經過幾次測試 發現大約是在內容字元超過950時會發生
使用內建的除錯 顯示錯誤發生在這一行:
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count,
rng.Columns.Count).Value = rng.Value
但我完全無法看出其中有任何限制欄位內容大小的部份
希望有知道如何修改的強者提點 <(_ _)>
該程式的全部內容如下:
來自http://www.vbaexpress.com/kb/getarticle.php?kb_id=151
(此網頁上的版本應該比較易於閱讀)
Sub CopyFromWorksheets()
Dim wrk As Workbook 'Workbook object - Always good to work with object
variables
Dim sht As Worksheet 'Object for handling worksheets in loop
Dim trg As Worksheet 'Master Worksheet
Dim rng As Range 'Range object
Dim colCount As Integer 'Column count in tables in the worksheets
Set wrk = ActiveWorkbook 'Working in active workbook
For Each sht In wrk.Worksheets
If sht.Name = "Master" Then
MsgBox "There is a worksheet called as 'Master'." & vbCrLf & _
"Please remove or rename this worksheet since 'Master' would be"
& _
"the name of the result worksheet of this process.", vbOKOnly +
vbExclamation, "Error"
Exit Sub
End If
Next sht
'We don't want screen updating
Application.ScreenUpdating = False
'Add new worksheet as the last worksheet
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
'Rename the new worksheet
trg.Name = "Master"
'Get column headers from the first worksheet
'Column count first
Set sht = wrk.Worksheets(1)
colCount = sht.Cells(1, 255).End(xlToLeft).Column
'Now retrieve headers, no copy&paste needed
With trg.Cells(1, 1).Resize(1, colCount)
.Value = sht.Cells(1, 1).Resize(1, colCount).Value
'Set font as bold
.Font.Bold = True
End With
'We can start loop
For Each sht In wrk.Worksheets
'If worksheet in loop is the last one, stop execution (it is Master
worksheet)
If sht.Index = wrk.Worksheets.Count Then
Exit For
End If
'Data range in worksheet - starts from second row as first rows are
the header rows in all worksheets
Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536,
1).End(xlUp).Resize(, colCount))
'Put data into the Master worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count,
rng.Columns.Count).Value = rng.Value
Application.DisplayAlerts = False
'cancel alert
sht.Delete
'delete sheet
Application.DisplayAlerts = True
'recovery alert
Next sht
'Fit the columns in Master worksheet
trg.Columns.AutoFit
'Screen updating should be activated
Application.ScreenUpdating = True
End Sub
--
--
※ 發信站: 批踢踢實業坊(ptt.cc)
◆ From: 61.231.53.33
推
12/31 20:42, , 1F
12/31 20:42, 1F