合并Excel表使用VBA [英] Merge Excel Sheets Using VBA
问题描述
这个行数（5000）不会改变一整年。
现在我有5个XL文件（说A，B，C，D，E），这些文件的数据必须追加到这个OG文件，每次从第5001行开始。
所有这5个文件的列数不同，但与OG文件相同。
我必须从这些文件中提取数据并将它们放在OG文件中。
从文件A：列A，B，C，D，E，F，G和H转到OG.xls文件的列F，G，T，U，V，W，X和Y。
同样，必须根据OG.xls的相应列提取其他文件数据
第二个文件数据必须附加在下一行的下方（文件A结束）（填写文件A中的数据后，OG.xls有5110行
文件B数据必须从5111行的OG.xls填充
相同
这5个文件的数据必须按行排列，但应与OG.xls的列匹配。
每次通过从第5001行OG.xls填充数据重复相同的操作，为方便起见，我们可以将所有这些文件放在同一个文件夹中。
我们如何这样做。
请帮助我在这个!!!
也让我知道任何澄清。
为什么列A在列F中结束，为什么C在T中结束？有没有这样的规则，如第一行是具有相同的标题文字我
也许照片可能有帮助。
根据我可以猜到的，我会投掷每个工作表都将带有有意义的字段名称（您需要参考 Microsoft ActiveX数据对象2.8库）。一旦完成，将很容易地附加每个RecordSet并将它们扔到一张单。
您需要能够找到最后一列和最后一行每张表都干净地去做，所以看看我如何找到最后一行...
编辑...
下面是一个清理示例，您可以如何在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作为新集合
Dim rsetList作为新集合
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
设置wb = ActiveWorkbook
对于每个sh在wb.Worksheets
设置rs =新记录集
ref = FindEndCell（sh）
cols = sh.Range （ref）.Column
rows = sh.Range（ref）.Row
如果ref< ;> $ A $ 1或sh.Range（ref）.Value<> 然后这是为了获取空的表格
c = 1
r = 1
尽管c <= cols
fldName = sh.Cells（r，c）.Value
rs.Fields.Append fldName，adVarChar，MAX_CHARS
如果不是InCollection（fieldList，fldName）然后
fieldList.Add fldName，fldName
如果
c = c + 1
循环
rs.Open
r = 2
尽管r <=行
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&行& ，& c& of& cols
循环
rsetList.Add rs，sh.Name
结束如果
下一个
设置mergedRS =新Recordset
c = 1
sourceColumn =SourceSheet
Do While InCollection（fieldList，sourceColumn）''以防您合并合并的工作表
sourceColumn =SourceSheet& c
c = c + 1
循环
mergedRS.Fields.Append sourceColumn，adVarChar，MAX_CHARS
对于每个f在fieldList
mergedRS.Fields.Append CStr（f） ，adVarChar，MAX_CHARS
下一个
mergedRS.Open
c = 1
对于每个rs在rsetList
如果rs.RecordCount> = 1然后
rs.MoveFirst
Do Until rs.EOF
mergedRS.AddNew
mergedRS.Fields（sourceColumn）=Sheet No.& c
对于每个f在rs.Fields
mergedRS.Fields（f.Name）= f.Value
下一个
rs.MoveNext
循环
结束如果
c = c + 1
下一个
设置sh = wb.Worksheets.Add
mergedRS.MoveFirst
r = 1
c = 1
对于每个f在mergedRS.Fields
sh.Cells（r，c）.Formula = f.Name
c = c + 1
下一个
r = 2
直到合并RS.EOF
c = 1
对于每个f在mergedRS.Fields
sh.Cells（r，c）.Value = f.Value
c = c + 1
下一个
r = r + 1
mergedRS.MoveNext
循环
结束子
公共函数InCollection（col As Collection，key As String）As Boolean
Dim var As Variant
Dim errNumber As Long
InCollection = False
设置var = Nothing
Err.Clear
错误恢复下一步
var = col.Item（key）
errNumber = CLng（Err.Number）
错误转到0
'5不在，0和438表示incollection
如果errNumber = 5然后'如果不是在集合$ 5
InCollection = False
Else
InCollection = True
如果
结束函数
公共函数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
如果cols> = maxCols Then
cols = 1
如果
c = 1
尽管c <= cols
r = sh.Cells （1，c）.End（xlDown）.Row
如果r> = maxRows然后
r = 1
如果
如果r>行然后
rows = r
结束如果
c = c + 1
循环
FindEndCell = sh.Cells（rows，cols）.Address
结束功能
I have a Excel Sheet(Say OG.xls) which has some data already in it with some 5000 rows with headings in the first row and Upto "AN" Columns. This No of rows(5000) doesn't change for a whole year. Now i have 5 XL files(Say A,B,C,D,E) and the data from these files has to be appended to this OG file just starting from 5001st row every time. All these 5 files has different no of columns but identical to that of OG File. I have to pull data from these files and place them in OG File. From File A : Column A,B,C,D,E,F,G&H goes to Column F,G,T,U,V,W,X&Y Of OG.xls File. Likewise the other files data has to be extracted according to the corresponding column with OG.xls
The second file data has to be appended right below the next row where the File A ends.(Say after filling the data from File A now the OG.xls has 5110 rows, the File B data has to filled from 5111 st row of OG.xls. The same follows for the other files too. The data of these 5 files has to be filled row after row but should match the columns to that of OG.xls
Each time the same operation is repeated by filling the data from 5001st row of OG.xls. For convenience we can have all these files in a same folder.
How can we do this.
Please help me in this!!! Also let me know for any clarifications.
Why does Column A end up in Column F, and why does C end up in T? Is there a rule around this such as the first row is a header with with the same text in it?
Maybe a picture might help.
Based on what i can guess, i'd throw each sheet into a RecordSet with meaningful field names (you'll need to reference Microsoft ActiveX Data Objects 2.8 Library) . Once done it will be very easy to append each RecordSet and throw them into a single sheet.
You'll need to be able to find the last column and last row in each sheet to do this cleanly so have a look at How can i find the last row...
Edit...
Below is a cleaned up example of how you could do what you need in VBA. The devil is in the details such as empty sheets, and how to handle formulas (this ignores them completely), and how to merge you columns in an appropriate way (again ignored).
This has been tested in 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
这篇关于合并Excel表使用VBA的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
