跨工作簿选择工作簿提取指定列数的数据填入到目标工作表指定的列号

weilaikeqiak

ykcbf1100 发表于 2024-8-25 12:18
改好了。。。

完美的运行，感谢草爷鲜花奉上！！！！

weilaikeqiak

Qs18 发表于 2024-8-25 10:33
Sub qs()
    Application.ScreenUpdating = False
    Dim arr, i, wb As Workbook, xb As Workbook

虽然运行功能没有达到我描述的结果，不过还是谢谢您的回帖

Qs18

weilaikeqiak 发表于 2024-8-25 14:48
虽然运行功能没有达到我描述的结果，不过还是谢谢您的回帖

你需要的是选择工作簿吗

Qs18

Sub qs()
    Application.ScreenUpdating = False
    Dim arr, i, wb As Workbook, xb As Workbook
        Dim FileName
    FileName = Application.GetOpenFilename(FileFilter:="Excel 工作簿文件 (*.xls*),*.xls*", Title:="请选择文件", MultiSelect:=True)
    If Not IsArray(FileName) Then
        MsgBox "没有选择文件"
        Exit Sub
    End If
    For Each f In FileName
        Set xb = Workbooks.Open(f, 0)
        rw = xb.Sheets(1).Cells(Rows.Count, "d").End(3).Row
        arr = xb.Sheets(1).Range("d2:i" & rw).Value
        xb.Close (0)
        For i = 2 To 3
            Sheet1.Cells(2, i).Resize(UBound(arr), 1) = Application.Index(arr, 0, i + 3)
            Sheet1.Cells(2, i + 4).Resize(UBound(arr), 1) = Application.Index(arr, 0, i + 3)
        Next
    Next f
    Application.ScreenUpdating = True
End Sub

Qs18

试试.............

Qs18

试试..........

weilaikeqiak

Qs18 发表于 2024-8-25 15:21
试试..........

提取过来的数据单位和数量两列是对的，编号和品号两列的数据不对

Qs18

weilaikeqiak 发表于 2024-8-25 15:48
提取过来的数据单位和数量两列是对的，编号和品号两列的数据不对

哦，代码改一下就可以了

Qs18

Sub qs()
    Application.ScreenUpdating = False
    Dim arr, i, wb As Workbook, xb As Workbook
        Dim FileName
    FileName = Application.GetOpenFilename(FileFilter:="Excel 工作簿文件 (*.xls*),*.xls*", Title:="请选择文件", MultiSelect:=True)
    If Not IsArray(FileName) Then
        MsgBox "没有选择文件"
        Exit Sub
    End If
    For Each f In FileName
        Set xb = Workbooks.Open(f, 0)
        rw = xb.Sheets(1).Cells(Rows.Count, "d").End(3).Row
        arr = xb.Sheets(1).Range("d2:i" & rw).Value
        xb.Close (0)
        For i = 2 To 3
            Sheet1.Cells(2, i).Resize(UBound(arr), 1) = Application.Index(arr, 0, i - 1)
            Sheet1.Cells(2, i + 4).Resize(UBound(arr), 1) = Application.Index(arr, 0, i + 3)
        Next
    Next f
    Application.ScreenUpdating = True
End Sub

Qs18

再测试一下..........