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

趣味阅读 · 发表于 2020-2-21 11:15

非常感谢，可以把提取的内容单独保存成独立的工作簿吗，工作簿名字根据sheet3里B3内容命名，工作簿里的工作表名字默认为sheet1

趣味阅读 · 发表于 2020-2-21 11:17

网海遨游发表于 2020-2-21 11:00
难道是要这样的????

非常感谢，提取的内容能保存到新建的工作簿中吗，工作簿名字根据sheet3中的B3内容命名，新工作簿中的工作表名字默认为sheet

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

数组也可以实现：

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
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

复制代码

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

请参考附件：

测试.rar (11.29 KB, 下载次数: 2)

趣味阅读 · 发表于 2020-2-21 11:34

shenjianrong163 发表于 2020-2-21 11:19
请参考附件：

生成的工作簿第一列序号可以重新排列吗，例如1、2、3、4...

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

你再看看,下载后测试测试.

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

复制代码

落雨惊涵 · 发表于 2020-2-21 13:39

一个简单的循环

趣味阅读 · 发表于 2020-2-21 14:11

问题已解决，非常感谢大家

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

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

再麻烦下老师，如果sheet2中的数据有固定的格式，如何让提取的数据保持原来的格式，行高、列宽、字体等。

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

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