根据sheet1第二列的型号，提取sheet2中对应的整行内容到新建工作簿中

趣味阅读 · 发表于 2020-2-21 09:56

shenjianrong163 · 发表于 2020-2-21 11:54

趣味阅读发表于 2020-2-21 11:34
生成的工作簿第一列序号可以重新排列吗，例如1、2、3、4...

Sub test()
Dim i, j, r, k, m, path, name, arr, brr, crr()
Dim wk As Workbook
path = ThisWorkbook.path
With Sheets("sheet3")
name = .Range("C3")
End With
With Sheets("sheet2")
arr = .UsedRange
End With
With Sheets("sheet1")
r = .Cells(.Rows.Count, 2).End(xlUp).Row
brr = .Range("B2:B" & r)
End With
m = 1
ReDim Preserve crr(1 To UBound(arr, 2), 1 To m)
For k = 1 To UBound(arr, 2)
crr(k, 1) = arr(1, k)
Next
For i = 1 To UBound(brr)
For j = 2 To UBound(arr)
If brr(i, 1) = arr(j, 2) Then
m = m + 1
ReDim Preserve crr(1 To UBound(arr, 2), 1 To m)
For k = 1 To UBound(arr, 2)
crr(k, m) = arr(j, k)
Next
crr(1, m) = m - 1
Exit For
End If
Next
Next
Set wk = Workbooks.Add '新建工作薄
Application.DisplayAlerts = False
With Sheets("Sheet1")
.[A1].Resize(UBound(crr, 2), UBound(crr)) = Application.Transpose(crr) '提取的数值存入工作薄的Sheet1中
End With
wk.SaveAs Filename:=ThisWorkbook.path & "/" & name & ".xlsx" '另存工作薄
wk.Close False
End Sub

复制代码

opel-wong · 发表于 2020-2-21 10:25

字典匹配就可以了，

网海遨游 · 发表于 2020-2-21 10:25

楼主是不是要这样的?

趣味阅读 · 发表于 2020-2-21 10:32

网海遨游发表于 2020-2-21 10:25
楼主是不是要这样的?

没描述清楚，把提取到的内容整合到一个新建的工作簿中，带表头

网海遨游 · 发表于 2020-2-21 10:36

趣味阅读发表于 2020-2-21 10:32
没描述清楚，把提取到的内容整合到一个新建的工作簿中，带表头

如何取工作薄的名称?

趣味阅读 · 发表于 2020-2-21 10:41

网海遨游发表于 2020-2-21 10:36
如何取工作薄的名称?

C:\Users\Administrator\Desktop\1.jpg

趣味阅读 · 发表于 2020-2-21 10:44

网海遨游发表于 2020-2-21 10:36
如何取工作薄的名称?

在sheet3中单独设置工作簿名称

网海遨游 · 发表于 2020-2-21 10:44

趣味阅读发表于 2020-2-21 10:41

这是什么意思? 工作薄名变成了图片名?

网海遨游 · 发表于 2020-2-21 10:45

趣味阅读发表于 2020-2-21 10:44
在sheet3中单独设置工作簿名称

晕,这是工作表名称,楼主.

网海遨游 · 发表于 2020-2-21 11:00

难道是要这样的????

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

[求助] 根据sheet1第二列的型号，提取sheet2中对应的整行内容到新建工作簿中