[已解决]求助将另外工作薄所有工作表数据导入的VBA代码修改

网络人 · 发表于 2017-8-19 13:47

本帖最后由网络人于 2017-8-23 13:59 编辑

求助将工作薄1内所有工作表的数据按照对应的名称导入到工作薄2内，具体见附件

最佳答案

月排行榜 / 总排行榜

苏子龙

2017-8-23 12:03

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim WB As Workbook, MySh As Worksheet, sh As Worksheet
Dim F, E
Dim arr, i&, Lastrow&, Xh&
Set MySh = ActiveWorkbook.Worksheets("sheet1") '为了确定用那个工作簿里的工作表，直接set下
MySh.Range("4:65536").Clear '删除原来的数据，若要接下去，就不用此句
F = False
For Each E In Workbooks
If E.Name = "工作簿1.xls" Then
F = True
If MsgBox("请关闭当前操作界面中已经打开的【工作簿1】后再操作！", 32 + 256) = 6 Then
Exit Sub
End If
End If
Next
If F = False Then
Set fso = CreateObject("scripting.filesystemobject")
Set fld = CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件夹", 0, 0)
If fld Is Nothing Then End
fp = fld.Self.Path
Workbooks.Open Filename:=fp & "" & "工作簿1.xls" '读入
Set WB = ActiveWorkbook
On Error Resume Next
For Each sh In WB.Worksheets
arr = sh.Range("a2:i" & sh.Cells(Rows.Count, 1).End(xlUp).Row)
Lastrow = IIf(Lastrow < 3, 3, MySh.Cells(MySh.Rows.Count, 5).End(3).Row) '由于mysh表格2,3行是合并的，所以加个判断
n = Lastrow '其实可以省略n,xh用一个参数就可以了，为了好理解就多加几个参数
For i = 2 To UBound(arr)
n = n + 1 '开始写入行号
Xh = Xh + 1 '序号
With MySh
.Cells(n, 1) = Xh
.Cells(n, 2) = sh.Name & "," & arr(i, 1) '备注加工作表名称加此序号，好查看
.Cells(n, 4) = arr(i, 2)
.Cells(n, 5) = arr(i, 3)
.Cells(n, 6) = arr(i, 4)
.Cells(n, 7) = arr(i, 5)
.Cells(n, 10) = arr(i, 6)
.Cells(n, 11) = arr(i, 7)
.Cells(n, 12) = arr(i, 8)
.Cells(n, 19) = arr(i, 9)
End With
Next i
Next sh
WB.Close savechanges:=False
Set WB = Nothing: Set MySh = Nothing: Erase arr
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

复制代码

跳转到最佳答案楼层

idnoidno · 发表于 2017-8-19 21:17

本帖最后由 idnoidno 于 2017-8-19 21:21 编辑

代碼是在工作簿1中新增一個工作表(TA)另2個工作表我改名為T、G，代碼執行是可以的，您試試

idnoidno · 发表于 2017-8-19 21:21

Option Explicit
Sub t1()
Dim ar, br, arow%, brow%, i%, j%, m%
With Worksheets("T")
arow = .Range("a65536").End(xlUp).Row
End With
With Worksheets("G")
brow = .Range("a65536").End(xlUp).Row
End With
ReDim br(1 To arow + brow + m, 1 To 12)
For i = 1 To Worksheets.Count - 1
With Worksheets(i)
ar = .Range("a3:i" & .Cells(Rows.Count, 1).End(xlUp).Row)
End With
For j = 1 To UBound(ar)
m = m + 1
br(m, 1) = m
br(m, 4) = ar(j, 2)
br(m, 5) = ar(j, 3)
br(m, 6) = ar(j, 4)
br(m, 7) = ar(j, 5)
br(m, 10) = ar(j, 6)
br(m, 11) = ar(j, 7)
br(m, 12) = ar(j, 8)
Next j
Next i
With Worksheets("TA")
.Range("a3:l3") = Array("序号", "订单备注", "省份", "加盟店", "订单号.", "柜体材料", "門板材料", "门板材料", "", "客戶", "联系电话", "地址")
.Range("a4").Resize(UBound(br, 1), UBound(br, 2)) = br
End With
End Sub

复制代码

idnoidno · 发表于 2017-8-19 21:23

很不好意思，因為系統無法使用簡體，所以只能調整字體

這是把彙整都做於工作簿1中

网络人 · 发表于 2017-8-21 08:09

idnoidno 发表于 2017-8-19 21:21

能否在我原有的代码上修改了

网络人 · 发表于 2017-8-21 08:23

idnoidno 发表于 2017-8-19 21:21

还有我导入的工作表内不止2个工作表，有可能是3个甚至是更多

idnoidno · 发表于 2017-8-21 09:43

代碼中的工作表可以不止一個，這是已經有考量，原有代碼修改，可能小弟的功力不夠，我再看看可不可以修改

网络人 · 发表于 2017-8-21 11:47

idnoidno 发表于 2017-8-21 09:43
代碼中的工作表可以不止一個，這是已經有考量，原有代碼修改，可能小弟的功力不夠，我再看看可不可以修改

我用你的代码修改总是少一个表

idnoidno · 发表于 2017-8-21 12:54

本帖最后由 idnoidno 于 2017-8-21 13:21 编辑

您可以把檔案丟上來看看，我的設定是少一個，因為最後一個是我輸出的目標工作表For i = 1 To Worksheets.Count - 1
這邊有減1

网络人 · 发表于 2017-8-21 14:52

本帖最后由网络人于 2017-8-21 15:41 编辑

idnoidno 发表于 2017-8-21 12:54
您可以把檔案丟上來看看，我的設定是少一個，因為最後一個是我輸出的目標工作表For i = 1 To Worksheets.Co ...

在原来的代码上修改了一下，但是是只能导入一个工作表的数据，麻烦高手帮忙看看怎么样修改代码

		自动登录	找回密码
密码			注册