EXCEL中 如何用宏实现 从每个其他的EXCEL提取特定一列放到一个新的EXCEL里？ 如何用宏把excel中每个工作表的第二列提取到新工作表中

详细Hi我

根据说明更改前面三行的参数：
--------------
Sub 合并选定工作簿的第1个工作表中的某几列()
Dim c0%: c0 = 1 '数据源表内，需要复制的列位置，1～256
Dim cNum%: cNum = 1 '单个数据源表内，需要复制的列数量，1～256
Dim c1%: c1 = 1 '结果表内，开始放置结果的列位置，1～256

Dim iBk0 As Workbook, iBk1 As Workbook, i%, iFiles
iFiles = Application.GetOpenFilename("Excel Files (*.xls), *.xls", , "请选择要合并的工作簿", , True)
If IsArray(iFiles) = 0 Then MsgBox "没有选择文件!": Exit Sub
Application.ScreenUpdating = False
Set iBk1 = ActiveWorkbook
For i = 1 To UBound(iFiles)
c1 = c1 + (i - 1) * cNum
If c1 + cNum - 1 > 256 Then MsgBox "列已放满256列！程序终止!": GoTo 100
Set iBk0 = GetObject(iFiles(i))
iBk0.Worksheets(1).Columns(c0).Resize(, cNum).Copy _
iBk1.Worksheets(1).Columns(c1).Resize(, cNum)
iBk0.Close False
Next i
100:
Set iBk0 = Nothing
Application.ScreenUpdating = True
MsgBox "完成！"
End Sub

详细Hi我

根据说明更改前面三行的参数:
--------------
Sub 合并选定工作簿的第1个工作表中的某几列()
Dim c0%: c0 = 1 '数据源表内，需要复制的列位置，1~256
Dim cNum%: cNum = 1 '单个数据源表内，需要复制的列数量，1~256
Dim c1%: c1 = 1 '结果表内，开始放置结果的列位置，1~256

Dim iBk0 As Workbook， iBk1 As Workbook， i%， iFiles
iFiles = Application.GetOpenFilename("Excel Files (*.xls)， *.xls"， ， "请选择要合并的工作簿"， ， True)
If IsArray(iFiles) = 0 Then MsgBox "没有选择文件，": Exit Sub
Application.ScreenUpdating = False
Set iBk1 = ActiveWorkbook
For i = 1 To UBound(iFiles)
c1 = c1 + (i - 1) * cNum
If c1 + cNum - 1 > 256 Then MsgBox "列已放满256列，程序终止，": GoTo 100
Set iBk0 = GetObject(iFiles(i))
iBk0.Worksheets(1).Columns(c0).Resize(， cNum).Copy _
iBk1.Worksheets(1).Columns(c1).Resize(， cNum)
iBk0.Close False
Next i
100:
Set iBk0 = Nothing
Application.ScreenUpdating = True。

如何快速在多个excel工作表里面提取同一列使之成为一个新的表格~

用万能的vba可以实现。举例说明。
例如有一文件，其中sheet1、sheet2、sheet3有数据如图：

现要求将sheet1~sheet3的a列提取后放到sheet4中。假定已知数据项的数量都相同且等于5.
第一步：插入模块，编制代码如下：
Sub 创建新表()Const hs = 5For i = 1 To hs Sheet4.Cells(i, 1) = Sheet1.Cells(i, 1) Sheet4.Cells(i, 2) = Sheet2.Cells(i, 1) Sheet4.Cells(i, 3) = Sheet3.Cells(i, 1)Next iEnd Sub第二步：运行该宏。结果如图：

1，程序为：
Sub 提取第二行()
Dim wks As Worksheet, sht As Worksheet
On Error Resume Next
Set wks = Worksheets("汇总表")
If Err 0 Then Worksheets.Add(before:=Sheets(1)).Name = "汇总表"
For Each sht In Sheets
If sht.Name "汇总表" Then
sht.Range("A2").EntireRow.Copy Sheets("汇总表").Range("A" & Sheets("汇总表").Cells(Rows.Count, 1).End(xlUp).Row + 1)
End If
Next
End Sub
2，如果没有汇总表则新建汇总表。将非汇总表的其他表里面的第二行分别复制并粘贴进汇总表，粘贴位置为A列的第一个空白行。