Sub Macro1()
Dim wb As Workbook, arr, rng As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wb = GetObject(ThisWorkbook.Path & "\数据源.xls")
arr = wb.Sheets(1).[b3:g3]
wb.Close 0
For i = 1 To UBound(arr, 2)
With Workbooks.Open(ThisWorkbook.Path & "\数据源.xls")
For j = 1 To .Sheets.Count
For Each m In .Sheets(j).[b3:g3]
If m <> arr(1, i) Then
If rng Is Nothing Then Set rng = m.Resize(100, 1) Else Set rng = Union(rng, m.Resize(100, 1))
End If
Next
If Not rng Is Nothing Then rng.Delete Shift:=xlToLeft
Set rng = Nothing
Next
.SaveAs Filename:=ThisWorkbook.Path & "\" & arr(1, i) & ".xls"
Workbooks(arr(1, i) & ".xls").Close 1
End With
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
vba语法翻译,求大神给翻译翻译。
答案:1 悬赏:80 手机版
解决时间 2021-04-09 21:00
- 提问者网友:溺爱和你
- 2021-04-08 22:17
最佳答案
- 五星知识达人网友:动情书生
- 2021-04-08 23:24
Sub Macro1()
'定义变量
Dim i, j
Dim wb As Workbook, arr, rng As Range
'关闭画面刷新
Application.ScreenUpdating = False
'如果宏运行时 Microsoft Excel 显示特定的警告和消息,则该属性值为 True。Boolean 类型,可读写。
Application.DisplayAlerts = False
'将当前文件路径下的excel文件——数据源 赋给变量wb
Set wb = GetObject(ThisWorkbook.Path & "\数据源.xls")
'数组 赋值 等于数据源的sheets(1)的B3:G3
arr = wb.Sheets(1).[b3:g3]
'关闭 wb
wb.Close 0
'循环 数组arr UBound(arr, 2)->其值为指定的数组维可用的最大下标
For i = 1 To UBound(arr, 2)
'打开数据源
With Workbooks.Open(ThisWorkbook.Path & "\数据源.xls")
'循环数据源的所有sheet
For j = 1 To .Sheets.Count
'循环当前sheet的B3:G3
For Each m In .Sheets(j).[b3:g3]
'如果当前cells 不等于 arr(1, i)
If m <> arr(1, i) Then
''rng 没有赋过值,肯定是nothing '这句可以在跟踪下
'可以 F8 逐句跟踪下
If rng Is Nothing Then Set rng = m.Resize(100, 1) Else Set rng = Union(rng, m.Resize(100, 1))
End If
Next
If Not rng Is Nothing Then rng.Delete Shift:=xlToLeft
Set rng = Nothing
Next
'新建文件 文件名为arr(1, i)
.SaveAs Filename:=ThisWorkbook.Path & "\" & arr(1, i) & ".xls"
'关币新建的文件
Workbooks(arr(1, i) & ".xls").Close 1
End With
Next
Application.DisplayAlerts = True
'打开画面刷新
Application.ScreenUpdating = True
End Sub
'定义变量
Dim i, j
Dim wb As Workbook, arr, rng As Range
'关闭画面刷新
Application.ScreenUpdating = False
'如果宏运行时 Microsoft Excel 显示特定的警告和消息,则该属性值为 True。Boolean 类型,可读写。
Application.DisplayAlerts = False
'将当前文件路径下的excel文件——数据源 赋给变量wb
Set wb = GetObject(ThisWorkbook.Path & "\数据源.xls")
'数组 赋值 等于数据源的sheets(1)的B3:G3
arr = wb.Sheets(1).[b3:g3]
'关闭 wb
wb.Close 0
'循环 数组arr UBound(arr, 2)->其值为指定的数组维可用的最大下标
For i = 1 To UBound(arr, 2)
'打开数据源
With Workbooks.Open(ThisWorkbook.Path & "\数据源.xls")
'循环数据源的所有sheet
For j = 1 To .Sheets.Count
'循环当前sheet的B3:G3
For Each m In .Sheets(j).[b3:g3]
'如果当前cells 不等于 arr(1, i)
If m <> arr(1, i) Then
''rng 没有赋过值,肯定是nothing '这句可以在跟踪下
'可以 F8 逐句跟踪下
If rng Is Nothing Then Set rng = m.Resize(100, 1) Else Set rng = Union(rng, m.Resize(100, 1))
End If
Next
If Not rng Is Nothing Then rng.Delete Shift:=xlToLeft
Set rng = Nothing
Next
'新建文件 文件名为arr(1, i)
.SaveAs Filename:=ThisWorkbook.Path & "\" & arr(1, i) & ".xls"
'关币新建的文件
Workbooks(arr(1, i) & ".xls").Close 1
End With
Next
Application.DisplayAlerts = True
'打开画面刷新
Application.ScreenUpdating = True
End Sub
我要举报
如以上回答内容为低俗、色情、不良、暴力、侵权、涉及违法等信息,可以点下面链接进行举报!
点此我要举报以上问答信息
大家都在看
推荐资讯