Почему столбец A заканчивается в столбце F, а почему C - в T? Есть ли какое-то правило, например, что первая строка - это заголовок с тем же текстом?
Может быть, картинка может помочь.
Исходя из того, что я могу догадаться, я бросил бы каждый лист в RecordSet со значимыми именами полей (вам нужно будет ссылаться на Microsoft ActiveX Data Objects 2.8 Library). После этого будет очень легко добавить каждый набор записей и выбросить их в один лист.
Вам нужно будет найти последний столбец и последнюю строку на каждом листе, чтобы сделать это чисто, поэтому взгляните на Как мне найти последнюю строку ...
Редактировать ...
Ниже приведен пример того, как вы можете делать то, что вам нужно в VBA. Дьявол кроется в деталях, таких как пустые листы, и как обращаться с формулами (это полностью их игнорирует), и как правильно объединить столбцы (снова игнорируется).
Это было проверено в Excel 2007.
Option Explicit
Const MAX_CHARS = 1200
Sub MergeAllSheets()
Dim rs As Recordset
Dim mergedRS As Recordset
Dim sh As Worksheet
Dim wb As Workbook
Dim fieldList As New Collection
Dim rsetList As New Collection
Dim f As Variant
Dim cols As Long
Dim rows As Long
Dim c As Long
Dim r As Long
Dim ref As String
Dim fldName As String
Dim sourceColumn As String
Set wb = ActiveWorkbook
For Each sh In wb.Worksheets
Set rs = New Recordset
ref = FindEndCell(sh)
cols = sh.Range(ref).Column
rows = sh.Range(ref).Row
If ref <> "$A$1" Or sh.Range(ref).Value <> "" Then '' This is to catch empty sheet
c = 1
r = 1
Do While c <= cols
fldName = sh.Cells(r, c).Value
rs.Fields.Append fldName, adVarChar, MAX_CHARS
If Not InCollection(fieldList, fldName) Then
fieldList.Add fldName, fldName
End If
c = c + 1
Loop
rs.Open
r = 2
Do While r <= rows
rs.AddNew
c = 1
Do While c <= cols
rs.Fields(c - 1) = CStr(sh.Cells(r, c).Value)
c = c + 1
Loop
r = r + 1
Debug.Print sh.Name & ": " & r & " of " & rows & ", " & c & " of " & cols
Loop
rsetList.Add rs, sh.Name
End If
Next
Set mergedRS = New Recordset
c = 1
sourceColumn = "SourceSheet"
Do While InCollection(fieldList, sourceColumn) '' Just in case you merge a merged sheet
sourceColumn = "SourceSheet" & c
c = c + 1
Loop
mergedRS.Fields.Append sourceColumn, adVarChar, MAX_CHARS
For Each f In fieldList
mergedRS.Fields.Append CStr(f), adVarChar, MAX_CHARS
Next
mergedRS.Open
c = 1
For Each rs In rsetList
If rs.RecordCount >= 1 Then
rs.MoveFirst
Do Until rs.EOF
mergedRS.AddNew
mergedRS.Fields(sourceColumn) = "Sheet No. " & c
For Each f In rs.Fields
mergedRS.Fields(f.Name) = f.Value
Next
rs.MoveNext
Loop
End If
c = c + 1
Next
Set sh = wb.Worksheets.Add
mergedRS.MoveFirst
r = 1
c = 1
For Each f In mergedRS.Fields
sh.Cells(r, c).Formula = f.Name
c = c + 1
Next
r = 2
Do Until mergedRS.EOF
c = 1
For Each f In mergedRS.Fields
sh.Cells(r, c).Value = f.Value
c = c + 1
Next
r = r + 1
mergedRS.MoveNext
Loop
End Sub
Public Function InCollection(col As Collection, key As String) As Boolean
Dim var As Variant
Dim errNumber As Long
InCollection = False
Set var = Nothing
Err.Clear
On Error Resume Next
var = col.Item(key)
errNumber = CLng(Err.Number)
On Error GoTo 0
'5 is not in, 0 and 438 represent incollection
If errNumber = 5 Then ' it is 5 if not in collection
InCollection = False
Else
InCollection = True
End If
End Function
Public Function FindEndCell(sh As Worksheet) As String
Dim cols As Long
Dim rows As Long
Dim maxCols As Long
Dim maxRows As Long
Dim c As Long
Dim r As Long
maxRows = sh.rows.Count
maxCols = sh.Columns.Count
cols = sh.Range("A1").End(xlToRight).Column
If cols >= maxCols Then
cols = 1
End If
c = 1
Do While c <= cols
r = sh.Cells(1, c).End(xlDown).Row
If r >= maxRows Then
r = 1
End If
If r > rows Then
rows = r
End If
c = c + 1
Loop
FindEndCell = sh.Cells(rows, cols).Address
End Function