一个Excel工作表,里面有若干个工作簿(sheet),
现在新建一个sheet,使得这个sheet用来存放结果,且是第一个sheet。
要求:
对于sheet,按照sheet的顺序,从左向右合并(从第二个sheet到最后一个sheet);
对于第2个sheet,从第10行开始,
提取B10、C10、D10的内容保存到第一个sheet的B、C、D列;
提取B11、C11、D11的内容保存到第一个sheet的B、C、D列;
*************
只要第N行的BN、CN、DN单元格的内容都不为空,就保存到第一个sheet的B、C、D列;
对于第3个sheet,从第10行开始,按照第2个sheet的办法保存数据到第1个sheet的B、C、D列;
对于第4个sheet,从第10行开始,按照第2个sheet的办法保存数据到第1个sheet的B、C、D列;
*************
对于最后一个sheet,从第10行开始,按照第2个sheet的办法保存数据到第1个sheet的B、C、D列;
也就是双重循环。但是我不会VBA,请问如何办?
请写出对应的VBA代码,最好给出一些注释(请理解我是菜鸟)
分太少了,发一个之前写过的合并多张Excel到单张Sheet的代码,供参考:
运行主函数 Excels_2_Sheet
Sub deleteCells()Dim s
Set s = ThisWorkbook.Sheets("Sheet1")
s.Cells.Delete
For Each shp In s.Shapes
shp.Delete
Next shp
Set s = Nothing
End Sub
Sub Excels_2_Sheet()
Dim FilesToOpen
Dim x As Integer, b, ws, ar
'On Error GoTo ErrHandler
Application.ScreenUpdating = False
Call deleteCells
Set b = Worksheets(1)
FilesToOpen = Application.GetOpenFilename(FileFilter:="MicroSoft Excel文件, *.xlsx; *.xls", MultiSelect:=True, Title:="要合并的文件")
If TypeName(FilesToOpen) = "Boolean" Then
MsgBox "没有选中的文件"
GoTo ExitHandler
End If
x = 1
While x <= UBound(FilesToOpen)
'Workbooks.Open Filename:=FilesToOpen(x)
Call pub_wbOpenOrActive2(FilesToOpen(x))
Set ws = Sheets(1)
ws.Activate
With ws
If .UsedRange.Address <> "$A$1" Then
'筛选
Cells.AutoFilter
Range("$A:$U").AutoFilter Field:=15, Criteria1:="=*(111111)*"
'复制
Set ar = Cells.SpecialCells(xlCellTypeVisible).Areas
If ar.Count > 2 Then
If b.Range("A1") = "" Then
ar(1).Copy b.Range("A1")
End If
For j = 2 To ar.Count - 1
ar(j).Copy b.Range("A" & b.Columns(1).Find("*", , , , 1, 2).Row + 1)
'b.Range("A" & Columns(1).Find("*", , , , 1, 2).Row + 1).PasteSpecial Paste:=xlPasteValues
Next j
End If
Set ar = Nothing
End If
End With
Set ws = Nothing
Call pub_wbClose2(FilesToOpen(x))
x = x + 1
Wend
ExitHandler:
Application.ScreenUpdating = True
ThisWorkbook.Activate
ThisWorkbook.Sheets(1).Activate
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub
Sub test()
For Each wbook In Workbooks
Debug.Print wbook.Name
Next wbook
End Sub
Sub pub_wbOpenOrActive(ByVal Wbdir As String, ByVal Wbname As String)
' 将某Excel文件打开,或者激活
' 如无此文件,弹出对话框
For Each wbook In Workbooks
If wbook.Name = Wbname Then
wbook.Activate
Exit Sub
End If
Next wbook
If Len(Dir(Wbdir & Wbname)) > 0 Then ' 存在此文件
Workbooks.Open Filename:=Wbdir & Wbname
'Workbooks(Right(WblocalName, Len(WblocalName) - InStrRev(WblocalName, "\"))).Activate
Else
MsgBox "无法找到 " & Wbdir & Wbname
Exit Sub
End If
End Sub
Sub pub_wbOpenOrActive2(ByVal wbLocalName As String)
' 将某Excel文件打开,或者激活
' 如无此文件,弹出对话框
For Each wbook In Workbooks
If wbook.Path & "\" & wbook.Name = wbLocalName Then
wbook.Activate
Exit Sub
End If
Next wbook
If Len(Dir(wbLocalName)) > 0 Then ' 存在此文件
Workbooks.Open Filename:=wbLocalName
'Workbooks(Right(WblocalName, Len(WblocalName) - InStrRev(WblocalName, "\"))).Activate
Else
MsgBox "无法找到 " & wbLocalName
Exit Sub
End If
End Sub
Sub pub_wbClose2(ByVal wbLocalName As String)
' 将某Excel文件关闭
' 如无此文件,忽略
For Each wbook In Workbooks
If wbook.Path & "\" & wbook.Name = wbLocalName Then
wbook.Close False
Exit Sub
End If
Next wbook
End Sub
温馨提示:答案为网友推荐,仅供参考
第1个回答 2015-06-01
Sub 合并数据()
Dim n As Integer
Sheets.Add before:=Sheets(1) '新建一个sheet,使得这个sheet用来存放结果,且是第一个sheet
ActiveSheet.Name = "结果"
n = 1
For i = 2 To Sheets.Count '从第二个sheet到最后一个sheet
For r = 10 To Sheets(i).UsedRange.Item(Sheets(i).UsedRange.Count).Row '从第十行到最后一行
If Application.WorksheetFunction.CountA(Sheets(i).Range("b" & r & ":d" & r)) = 3 Then '如果第r行的Br、Cr、Dr单元格的内容都不为空
For c = 2 To 4
Sheets("结果").Cells(n, c) = Sheets(i).Cells(r, c) '保存到第一个sheet的B、C、D列
Next c
n = n + 1
End If
Next r
Next i
End Sub 追问
Dim n As Integer
Sheets.Add before:=Sheets(1) '新建一个sheet,使得这个sheet用来存放结果,且是第一个sheet
ActiveSheet.Name = "结果"
n = 1
For i = 2 To Sheets.Count '从第二个sheet到最后一个sheet
For r = 10 To Sheets(i).UsedRange.Item(Sheets(i).UsedRange.Count).Row '从第十行到最后一行
If Application.WorksheetFunction.CountA(Sheets(i).Range("b" & r & ":d" & r)) = 3 Then '如果第r行的Br、Cr、Dr单元格的内容都不为空
For c = 2 To 4
Sheets("结果").Cells(n, c) = Sheets(i).Cells(r, c) '保存到第一个sheet的B、C、D列
Next c
n = n + 1
End If
Next r
Next i
End Sub
已上传附件,点击按钮即可验证
很不错的回答,手机上采纳!
本回答被提问者和网友采纳第2个回答 2015-06-01
你说的不少,看不清楚。建议你出示一个样表说说。