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

weilaikeqiak

如何用VBA跨工作簿可以选择指定的工作簿里的指定列数的数据填入到当前工作表（目标工作表）指定的列号，请指教。。。

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.8.22
   
2.     Application.ScreenUpdating = False
   
3.     With Application.FileDialog(msoFileDialogFilePicker)
   
4.         .InitialFileName = ThisWorkbook.Path & ""
   
5.         .Title = "请选择对应Excel文件"
   
6.         .AllowMultiSelect = False
   
7.         .Filters.Clear
   
8.         .Filters.Add "Excel文件", "*.xls*"
   
9.         If .Show Then f = .SelectedItems(1) Else Exit Sub
   
10.     End With
    
11.     Set wb = Workbooks.Open(f, 0)
    
12.     With wb.Sheets(1)
    
13.         r = .Cells(Rows.Count, 2).End(3).Row
    
14.         arr = .[d2].Resize(r - 1, 2)
    
15.         brr = .[h2].Resize(r - 1, 2)
    
16.     End With
    
17.     wb.Close 0
    
18.     With Sheets("Sheet1")
    
19.       .[b2].Resize(UBound(arr), 2) = arr
    
20.       .[f2].Resize(UBound(brr), 2) = brr
    
21.     End With
    
22.     Application.ScreenUpdating = True
    
23.     MsgBox "OK！"
    
24. End Sub
    

复制代码

weilaikeqiak

感谢草爷，完美解决！！！！！

weilaikeqiak

ykcbf1100 发表于 2024-8-22 12:42
参与一下。。。

再次请教草爷一个问题，如果源表里面D列数据范围里面有空的单元格，那么空单元格对应的这一整行的数据就不需要提取目标表格指定的列，反之就正常提取。请帮忙修正一下代码，谢谢。

Qs18

Sub qs()
    Application.ScreenUpdating = False
    Dim arr, i, wb As Workbook, xb As Workbook
    ph = ThisWorkbook.Path & "\"
    Set xb = Workbooks.Open(ph & "源表.xlsx", 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
    Application.ScreenUpdating = True
End Sub

Qs18

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

Qs18

试试......

ykcbf1100

weilaikeqiak 发表于 2024-8-25 09:42
再次请教草爷一个问题，如果源表里面D列数据范围里面有空的单元格，那么空单元格对应的这一整行的数据就 ...

改好了。。。

ykcbf1100

改好了。。。

1. Sub ykcbf()   '//2024.8.25
   
2.     Application.ScreenUpdating = False
   
3.     With Application.FileDialog(msoFileDialogFilePicker)
   
4.         .InitialFileName = ThisWorkbook.Path & ""
   
5.         .Title = "请选择对应Excel文件"
   
6.         .AllowMultiSelect = False
   
7.         .Filters.Clear
   
8.         .Filters.Add "Excel文件", "*.xls*"
   
9.         If .Show Then f = .SelectedItems(1) Else Exit Sub
   
10.     End With
    
11.     Set wb = Workbooks.Open(f, 0)
    
12.     With wb.Sheets(1)
    
13.         r = .Cells(Rows.Count, 2).End(3).Row
    
14.         ReDim arr(1 To r, 1 To 2)
    
15.         ReDim brr(1 To r, 1 To 2)
    
16.         For i = 2 To r
    
17.             If .Cells(i, 4) <> Empty Then
    
18.                 m = m + 1
    
19.                 arr(m, 1) = .Cells(i, 4)
    
20.                 arr(m, 2) = .Cells(i, 5)
    
21.                 brr(m, 1) = .Cells(i, 8)
    
22.                 brr(m, 2) = .Cells(i, 9)
    
23.             End If
    
24.         Next
    
25.     End With
    
26.     wb.Close 0
    
27.     With Sheets("Sheet1")
    
28.         .[b2].Resize(m, 2) = arr
    
29.         .[f2].Resize(m, 2) = brr
    
30.     End With
    
31.     Application.ScreenUpdating = True
    
32.     MsgBox "OK！"
    
33. End Sub
    
34. 
    

复制代码