[已解决]VBA程序: "新建,筛选,复制,自动填充,另存"请求高人指点

BrianBrian

程序是因为如下需求编的:

1.打开工作薄"VBA.xlsm", 程序运行.
2.工作薄" VBA 筛选测试.xlsx": sheet("ZOSO") 中, 所有"J"列值为 "#N/A" 的行, copy 该行F 和 G的单元格内容到sheet ("IPES data") A列和B列下面空白单元格. 同时"C629"中的公式自动往下填充.
3. 表格按日期另存为一个新的文件. (因每天需要更新的频率太高)

新手刚上路, 还请高人多多帮忙, 不知如下程序是哪出错了. 谢谢!

Sub PRCordcontrolnew()
Dim myapp2 As Object
Dim wkb3 As Object
Dim arr, arr1(), m As Long, n As Long, o As Long, p As Long

Set myapp2 = CreateObject("Excel.Application")
Set wkb3 = myapp2.Workbooks.Open("C:\Documents and Settings\Desktop\VBA 筛选测试.xlsx") '以新的workbook object"wkb3"调用打开范本文件

wkb3.Sheets("ZOSO").Activate
arr = wkb3.Sheets("ZOSO").Range("E2:I" & Range("E1048576").End(xlUp).Row).Value
o = wkb3.Sheets("ZOSO").Range("C1048576").End(xlUp).Row

For m = 1 To UBound(arr)
If VarType(arr(m, 5)) = vbError Then
n = n + 1
ReDim Preserve arr1(1 To 5, 1 To n) '筛选出数组arr中#N/A值的元素,并归类为新的二维数组 arr1
arr1(1, n) = arr(m, 1) '取 第1维(共5个元素)的第一个元素对应的第二维所有值
arr1(2, n) = arr(m, 2) '取 第1维(共5个元素)的第二个元素对应的第二维所有值
End If
Next m

wkb3.Sheets("IPES data").Activate '把新的数组arr1取得的如上值复制到sheets("IPES")
wkb3.Sheets("IPES data").Range("A" & o).Resize(UBound(arr1, 2), UBound(arr1)) = Application.Transpose(arr1)
wkb3.Sheets("IPES data").Range("A" & o).Resize(UBound(arr1, 2), UBound(arr1)).Borders.LineStyle = 1
wkb3.Sheets("IPES data").Range("A" & o + UBound(arr1, 2)).Select

p = wkb3.Sheets("IPES data").Range("A1048576").End(xlUp).Row
With wkb3.Sheets("IPES data")
.Range("C628").AutoFill Destination:=.Range("C628:C" & p), Type:=xlFillDefault 'Sheet(IPES)单元格C628公式自动往下填充
End With

wkb3.SaveAs Filename:="C:\Documents and Settings\Desktop\PRC order control\" & "PRC Order Control" & Format(Now(), "YYYYMMDDHH") & " .xlsx" 'WK3 按日期和时间另存为新文件
wkb3.Close 0
Set wkb3 = Nothing
Set myapp2 = Nothing
End Sub

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-4-1 08:30

1. Sub PRCordcontrolnew2()
   
2. 
   
3.     On Error Resume Next
   
4. 
   
5.     Dim wkb3 As Workbook
   
6.     Dim arr, arr1(), m As Long, n As Long, o As Long, p As Long
   
7. 
   
8.     Application.ScreenUpdating = False
   
9.     Set wkb3 = GetObject(ThisWorkbook.Path & "\VBA 筛选测试.xlsx")
   
10.    
    
11.     With wkb3.Sheets("ZOSO")
    
12.         arr = .Range("E2:I" & .Cells(Rows.Count, 3).End(xlUp).Row)
    
13.     End With
    
14. 
    
15.     For m = 1 To UBound(arr)
    
16.         If VarType(arr(m, 5)) = vbError Then
    
17.             n = n + 1
    
18.             ReDim Preserve arr1(1 To 2, 1 To n)    '筛选出数组arr中#N/A值的元素,并归类为新的二维数组 arr1
    
19.             arr1(1, n) = arr(m, 1)
    
20.             arr1(2, n) = arr(m, 2)
    
21.         End If
    
22.     Next m
    
23. 
    
24.     With wkb3.Sheets("IPES data")
    
25.         p = .Cells(Rows.Count, 1).End(xlUp).Row
    
26.         If p > 1 Then Range("a2:c" & p) = ""
    
27.         If n > 0 Then
    
28.             .Range("A" & 2).Resize(n, UBound(arr1)) = Application.Transpose(arr1)
    
29.             .Range("A" & 2).Resize(n, UBound(arr1)).Borders.LineStyle = 1
    
30.             .[c2] = "=MID(RC[-1],11,4)/1000*MID(RC[-1],16,4)/1000*MID(RC[-1],29,4)"
    
31.             .Range("C2").AutoFill Destination:=.Range("C2:C" & n + 1), Type:=xlFillDefault    'Sheet(IPES)单元格C628公式自动往下填充
    
32.         End If
    
33.     End With
    
34. 
    
35. 
    
36.     wkb3.SaveAs Filename:="C:\Documents and Settings\Desktop\PRC order control" & "PRC Order Control" & Format(Now(), "YYYYMMDDHH") & " .xlsx"    'WK3 按日期和时间另存为新文件
    
37. 
    
38.     wkb3.Close 0
    
39. 
    
40.     Set wkb3 = Nothing
    
41.    
    
42.     Application.ScreenUpdating = True
    
43.    
    
44. End Sub
    

复制代码

跳转到最佳答案楼层

hwc2ycy

为什么你在IPS DATA输出位置要用ZOSO的最后行位置呢？
公式下拉，中间有空行，公式下拉填充必然有错误。

hwc2ycy

如果是需要C628的公式，可以直接在筛选的数据里输入再填充。

hwc2ycy

1. Sub PRCordcontrolnew2()
   
2. 
   
3.     On Error Resume Next
   
4. 
   
5.     Dim wkb3 As Workbook
   
6.     Dim arr, arr1(), m As Long, n As Long, o As Long, p As Long
   
7. 
   
8.     Application.ScreenUpdating = False
   
9.     Set wkb3 = GetObject(ThisWorkbook.Path & "\VBA 筛选测试.xlsx")
   
10.    
    
11.     With wkb3.Sheets("ZOSO")
    
12.         arr = .Range("E2:I" & .Cells(Rows.Count, 3).End(xlUp).Row)
    
13.     End With
    
14. 
    
15.     For m = 1 To UBound(arr)
    
16.         If VarType(arr(m, 5)) = vbError Then
    
17.             n = n + 1
    
18.             ReDim Preserve arr1(1 To 2, 1 To n)    '筛选出数组arr中#N/A值的元素,并归类为新的二维数组 arr1
    
19.             arr1(1, n) = arr(m, 1)
    
20.             arr1(2, n) = arr(m, 2)
    
21.         End If
    
22.     Next m
    
23. 
    
24.     With wkb3.Sheets("IPES data")
    
25.         p = .Cells(Rows.Count, 1).End(xlUp).Row
    
26.         If p > 1 Then Range("a2:c" & p) = ""
    
27.         If n > 0 Then
    
28.             .Range("A" & 2).Resize(n, UBound(arr1)) = Application.Transpose(arr1)
    
29.             .Range("A" & 2).Resize(n, UBound(arr1)).Borders.LineStyle = 1
    
30.             .[c2] = "=MID(RC[-1],11,4)/1000*MID(RC[-1],16,4)/1000*MID(RC[-1],29,4)"
    
31.             .Range("C2").AutoFill Destination:=.Range("C2:C" & n + 1), Type:=xlFillDefault    'Sheet(IPES)单元格C628公式自动往下填充
    
32.         End If
    
33.     End With
    
34. 
    
35. 
    
36.     wkb3.SaveAs Filename:="C:\Documents and Settings\Desktop\PRC order control" & "PRC Order Control" & Format(Now(), "YYYYMMDDHH") & " .xlsx"    'WK3 按日期和时间另存为新文件
    
37. 
    
38.     wkb3.Close 0
    
39. 
    
40.     Set wkb3 = Nothing
    
41.    
    
42.     Application.ScreenUpdating = True
    
43.    
    
44. End Sub
    

复制代码

BrianBrian

谢谢老师! P值, M值都可以跑出来,就是好像最后一步的时候#N/A 的部分值跑不到sheets (IPES), 不知道是我的电脑问题还是,我明早再把数据调出跑跑看看.  老师的条例太清晰了,学习了

BrianBrian

终于可以了呵,谢谢老师!