以文本方式查看主题

-  Foxtable(狐表)  (http://www.foxtable.com/bbs/index.asp)
--  专家坐堂  (http://www.foxtable.com/bbs/list.asp?boardid=2)
----  EXCEL自动更新表  (http://www.foxtable.com/bbs/dispbbs.asp?boardid=2&id=55943)

--  作者:发财
--  发布时间:2014/8/26 15:56:00
--  EXCEL自动更新表
Dim Book As New XLS.Book(ProjectPath & "汇总单表\\汇总单表.xls")
Dim Sheet1 As XLS.Sheet = Book.Sheets("日期")
Dim cj As WinForm.DateTimePicker = e.Form.Controls("DateTimePicker2")
If cj.Text =Nothing Then
    messagebox.show("请在导入月终日期输入日期!")
Else
    Sheet1(3,3).Value = cj.text
    Sheet1(6,3).Value = cj.text
    Book.Save(ProjectPath & "汇总单表\\汇总单表1.xls")
    Dim App As New MSExcel.Application
    Dim Wb As MSExcel.WorkBook = App.WorkBooks.open(ProjectPath & "汇总单表\\汇总单表1.xls")
    Dim Ws1 As MSExcel.WorkSheet = Wb.WorkSheets("日期")
    Dim Ws2 As MSExcel.WorkSheet = Wb.WorkSheets("分户快报")
    Dim Ws3 As MSExcel.WorkSheet = Wb.WorkSheets("资产负债表")
    Dim Ws4 As MSExcel.WorkSheet = Wb.WorkSheets("利润及分配表")
    Dim Ws5 As MSExcel.WorkSheet = Wb.WorkSheets("费用表")
    Dim Ws6 As MSExcel.WorkSheet = Wb.WorkSheets("附列资料")
    Dim Ws7 As MSExcel.WorkSheet = Wb.WorkSheets("工资月报")
    Dim Ws8 As MSExcel.WorkSheet = Wb.WorkSheets("茂名快报")
    Dim Ws9 As MSExcel.WorkSheet = Wb.WorkSheets("分单位")
    Dim Ws10 As MSExcel.WorkSheet = Wb.WorkSheets("资产负债指标表")
    Dim Ws11 As MSExcel.WorkSheet = Wb.WorkSheets("利润及相关指标表")
    ws1.UsedRange.Formula = ws1.UsedRange.Formula
    ws2.UsedRange.Formula = ws2.UsedRange.Formula
    ws3.UsedRange.Formula = ws3.UsedRange.Formula
    ws4.UsedRange.Formula = ws4.UsedRange.Formula
    ws5.UsedRange.Formula = ws5.UsedRange.Formula
    ws6.UsedRange.Formula = ws6.UsedRange.Formula
    ws7.UsedRange.Formula = ws7.UsedRange.Formula
    ws8.UsedRange.Formula = ws8.UsedRange.Formula
    ws9.UsedRange.Formula = ws9.UsedRange.Formula
    ws10.UsedRange.Formula = ws10.UsedRange.Formula
    ws11.UsedRange.Formula = ws11.UsedRange.Formula

    wb.save
    wb.close
    App.Quit
    
    Dim Proc As New Process
    Proc.File = (ProjectPath & "汇总单表\\汇总单表1.xls")
    Proc.Start()
End If
其中汇总单表链接表外数据,每次打开时都要求自动更新的,因而打开时出现错误报表,并自动添加了一个表ONGRGUT,不知如何修改呢?

--  作者:有点甜
--  发布时间:2014/8/26 16:00:00
--  
 哪段代码错?vba不是可以控制的么?你就不能全部用vba去做?
--  作者:发财
--  发布时间:2014/8/26 16:28:00
--  
全部用vba做就行了。感谢了!
--  作者:发财
--  发布时间:2014/8/27 15:36:00
--  
Dim aa1() As String = {"日期","分户快报","资产负债表","利润及分配表","费用表","附列资料","工资月报","茂名快报","分单位","资产负债指标表","利润及相关指标表"}
For i1 As Integer = 1 To 11
            Dim Ws(i1) As MSExcel.WorkSheet = Wb.WorkSheets(aa1(i1))
Next
上述代码为什么不行?

--  作者:有点甜
--  发布时间:2014/8/27 15:41:00
--  
Dim aa1() As String = {"日期","分户快报","资产负债表","利润及分配表","费用表","附列资料","工资月报","茂名快报","分单位","资产负债指标表","利润及相关指标表"}
For i1 As Integer = 0 To 10
    Dim Ws(i1) As MSExcel.WorkSheet = Wb.WorkSheets(aa1(i1))
Next

--  作者:发财
--  发布时间:2014/8/27 15:43:00
--  
还是不行?
--  作者:有点甜
--  发布时间:2014/8/27 15:49:00
--  
以下是引用发财在2014-8-27 15:43:00的发言:
还是不行?

 

例子,代码,全部发上来。

 

问问题不要说一句没一句的,别人不知道你什么意思


--  作者:发财
--  发布时间:2014/8/27 16:33:00
--  
Dim cj As WinForm.DateTimePicker = e.Form.Controls("DateTimePicker2")
If cj.Text = Nothing Then
    messagebox.show("请在导入月终日期输入日期!")
Else
    Dim y,m,d1 As Integer
    Dim dt2 As Date
    dt2 = vars("cc")
    Dim dt1 As Date = #1/01/0001#
    DateYMD(dt1,dt2, y, m, d1)
    y=y+1
    m=m+1
    d1=d1+1
    Dim f0l As String = "E:\\快盘\\excel" & y & "\\汇总单表" & y & "0" & m & ".xls"
    If Not FileSys.FileExists(f0l) Then
        Dim fl As String = "E:\\快盘\\excel" & y & "\\集团汇总" & y & "0" & m & ".xls"
        If Not FileSys.FileExists(fl) Then
            Messagebox.Show("请先生成:集团汇总" & y & "0" & m & "","提示")
        Else
            FileSys.CopyFile("E:\\快盘\\excel" & y & "\\汇总单表" & y & "0" & m-1 & ".xls", ProjectPath & "\\汇总单表\\上月汇总单表.xls",True)
            FileSys.CopyFile("E:\\快盘\\excel" & y-1 & "\\汇总单表" & y-1 & "0" & m & ".xls", ProjectPath & "\\汇总单表\\上年同期汇总单表.xls",True)
            FileSys.CopyFile("E:\\快盘\\excel" & y & "\\集团汇总" & y & "0" & m & ".xls", ProjectPath & "\\汇总单表\\集团汇总.xls",True)
            Dim Book As New XLS.Book(ProjectPath & "汇总单表\\汇总单表.xls")
            Dim App As New MSExcel.Application
            Dim rg1,rg2,rg3,rg4,rg5 As MSExcel.Range
            Dim Wb As MSExcel.WorkBook = App.WorkBooks.open(ProjectPath & "汇总单表\\汇总单表.xls")
            Dim Ws1 As MSExcel.WorkSheet = Wb.WorkSheets("日期")
            Dim Ws2 As MSExcel.WorkSheet = Wb.WorkSheets("分户快报")
            Dim Ws3 As MSExcel.WorkSheet = Wb.WorkSheets("资产负债表")
            Dim Ws4 As MSExcel.WorkSheet = Wb.WorkSheets("利润及分配表")
            Dim Ws5 As MSExcel.WorkSheet = Wb.WorkSheets("费用表")
            Dim Ws6 As MSExcel.WorkSheet = Wb.WorkSheets("附列资料")
            Dim Ws7 As MSExcel.WorkSheet = Wb.WorkSheets("工资月报")
            Dim Ws8 As MSExcel.WorkSheet = Wb.WorkSheets("茂名快报")
            Dim Ws9 As MSExcel.WorkSheet = Wb.WorkSheets("分单位")
            Dim Ws10 As MSExcel.WorkSheet = Wb.WorkSheets("资产负债指标表")
            Dim Ws11 As MSExcel.WorkSheet = Wb.WorkSheets("利润及相关指标表")
            Ws1.cells(4,4) = cj.text
            Ws1.cells(7,4) = cj.text
            rg1 =  Ws3.cells(14,5)
            rg2 =  Ws3.cells(15,9)
            rg3 = Ws4.cells(23,5)
            rg4 = Ws4.cells(31,5)
            rg5 =  Ws5.cells(32,5)
            rg1.value = rg1.value - vars("tx1")
            rg2.value= rg2.value - vars("tx1")
            rg3.value = rg3.value- vars("tx2")
            rg4.value= rg4.value- vars("tx2")
            rg5.value= rg5.value- vars("tx2")
            ws1.UsedRange.Formula = ws1.UsedRange.Formula
            ws2.UsedRange.Formula = ws2.UsedRange.Formula
            ws3.UsedRange.Formula = ws3.UsedRange.Formula
            ws4.UsedRange.Formula = ws4.UsedRange.Formula
            ws5.UsedRange.Formula = ws5.UsedRange.Formula
            ws6.UsedRange.Formula = ws6.UsedRange.Formula
            ws7.UsedRange.Formula = ws7.UsedRange.Formula
            ws8.UsedRange.Formula = ws8.UsedRange.Formula
            ws9.UsedRange.Formula = ws9.UsedRange.Formula
            ws10.UsedRange.Formula = ws10.UsedRange.Formula
            ws11.UsedRange.Formula = ws11.UsedRange.Formula
            app.displayalerts=False
            wb.saveas("E:\\快盘\\excel" & y & "\\汇总单表" & y & "0" & m & ".xls")
            wb.close
            App.Quit
            Dim Proc As New Process
            Proc.File = ("E:\\快盘\\excel" & y & "\\汇总单表" & y & "0" & m & ".xls")
            Proc.Start()
        End If
    Else
        If MessageBox.Show("是否将链接粘贴回数值,估计每个表要20秒?","确  认",MessageBoxButtons.OKCancel,MessageBoxIcon.Question) =DialogResult.OK Then
            Dim App As New MSExcel.Application
            Dim Wb As MSExcel.Workbook = App.WorkBooks.open("E:\\快盘\\excel" & y & "\\汇总单表" & y & "0" & m & ".xls")
            For Each Ws As MSExcel.WorkSheet In Wb.WorkSheets
                Ws.UnProtect
                Dim ds() As String = {"\'C", "\'D", "\'E"}
                Dim Rg As MSExcel.Range = Ws.UsedRange
                Dim ary = rg.Formula
                For i As Integer = 1 To Ws.UsedRange.Rows.Count
                    For j As Integer = 1 To Ws.UsedRange.Columns.Count
                        For Each d As String In ds
                            If ary(i,j) > "" AndAlso ary(i,j).Toupper.StartsWith("=" & d) Then
                                ws.cells(i,j).copy
                                ws.cells(i,j).PasteSpecial(Paste:=MSExcel.XlPasteType.xlPasteValues,   Operation:=MSExcel.XlPasteSpecialOperation.xlPasteSpecialOperationNone, SkipBlanks:=False, Transpose:=False)
                            End If
                        Next
                    Next
                Next
            Next
            Wb.Save
            App.Quit
        End If
        Dim Proc As New Process
        Proc.File = ("E:\\快盘\\excel" & y & "\\汇总单表" & y & "0" & m & ".xls")
        Proc.Start()
    End If
End If

--  作者:发财
--  发布时间:2014/8/27 16:35:00
--  
1.我想简化ws1至ws11
2.粘贴回数值时出现错误:Overload resolution failed because no accessible \'Chars\' accepts this number of arguments.

--  作者:有点甜
--  发布时间:2014/8/27 16:43:00
--  

 

Dim cj As WinForm.DateTimePicker = e.Form.Controls("DateTimePicker2")
If cj.Text = Nothing Then
    messagebox.show("请在导入月终日期输入日期!")
Else
    Dim y,m,d1 As Integer
    Dim dt2 As Date
    dt2 = vars("cc")
    Dim dt1 As Date = #1/01/0001#
    DateYMD(dt1,dt2, y, m, d1)
    y=y+1
    m=m+1
    d1=d1+1
    Dim f0l As String = "E:\\快盘\\excel" & y & "\\汇总单表" & y & "0" & m & ".xls"
    If Not FileSys.FileExists(f0l) Then
        Dim fl As String = "E:\\快盘\\excel" & y & "\\集团汇总" & y & "0" & m & ".xls"
        If Not FileSys.FileExists(fl) Then
            Messagebox.Show("请先生成:集团汇总" & y & "0" & m & "","提示")
        Else
            FileSys.CopyFile("E:\\快盘\\excel" & y & "\\汇总单表" & y & "0" & m-1 & ".xls", ProjectPath & "\\汇总单表\\上月汇总单表.xls",True)
            FileSys.CopyFile("E:\\快盘\\excel" & y-1 & "\\汇总单表" & y-1 & "0" & m & ".xls", ProjectPath & "\\汇总单表\\上年同期汇总单表.xls",True)
            FileSys.CopyFile("E:\\快盘\\excel" & y & "\\集团汇总" & y & "0" & m & ".xls", ProjectPath & "\\汇总单表\\集团汇总.xls",True)
            Dim Book As New XLS.Book(ProjectPath & "汇总单表\\汇总单表.xls")
            Dim App As New MSExcel.Application
            Dim rg1,rg2,rg3,rg4,rg5 As MSExcel.Range
           
            Dim Wb As MSExcel.WorkBook = App.WorkBooks.open(ProjectPath & "汇总单表\\汇总单表.xls")
           
            Dim aa1() As String = {"日期","分户快报","资产负债表","利润及分配表","费用表","附列资料","工资月报","茂名快报","分单位","资产负债指标表","利润及相关指标表"}
            Dim Ws(aa1.Length) As MSExcel.WorkSheet
            For i1 As Integer = 1 To 11
                Ws(i1) = Wb.WorkSheets(aa1(i1))
            Next
            ws(1).cells(4,4) = cj.text
            ws(1).cells(7,4) = cj.text
            rg1 =  ws(3).cells(14,5)
            rg2 =  ws(3).cells(15,9)
            rg3 = ws(4).cells(23,5)
            rg4 = ws(4).cells(31,5)
            rg5 =  ws(5).cells(32,5)
            rg1.value = rg1.value - vars("tx1")
            rg2.value= rg2.value - vars("tx1")
            rg3.value = rg3.value- vars("tx2")
            rg4.value= rg4.value- vars("tx2")
            rg5.value= rg5.value- vars("tx2")
           
            For i1 As Integer = 1 To 11
                ws(i1).UsedRange.Formula = ws(i1).UsedRange.Formula
            Next

            app.displayalerts=False
            wb.saveas("E:\\快盘\\excel" & y & "\\汇总单表" & y & "0" & m & ".xls")
            wb.close
            App.Quit
            Dim Proc As New Process
            Proc.File = ("E:\\快盘\\excel" & y & "\\汇总单表" & y & "0" & m & ".xls")
            Proc.Start()
        End If
    Else
        If MessageBox.Show("是否将链接粘贴回数值,估计每个表要20秒?","确  认",MessageBoxButtons.OKCancel,MessageBoxIcon.Question) =DialogResult.OK Then
            Dim App As New MSExcel.Application
            Dim Wb As MSExcel.Workbook = App.WorkBooks.open("E:\\快盘\\excel" & y & "\\汇总单表" & y & "0" & m & ".xls")
            For Each Ws As MSExcel.WorkSheet In Wb.WorkSheets
                Ws.UnProtect
                Dim ds() As String = {"\'C", "\'D", "\'E"}
                Dim Rg As MSExcel.Range = Ws.UsedRange
                Dim ary = rg.Formula
                For i As Integer = 1 To Ws.UsedRange.Rows.Count
                    For j As Integer = 1 To Ws.UsedRange.Columns.Count
                        For Each d As String In ds
                            If ary(i,j) > "" AndAlso ary(i,j).Toupper.StartsWith("=" & d) Then
                                ws.cells(i,j).copy
                                ws.cells(i,j).PasteSpecial(Paste:=MSExcel.XlPasteType.xlPasteValues,   Operation:=MSExcel.XlPasteSpecialOperation.xlPasteSpecialOperationNone, SkipBlanks:=False, Transpose:=False)
                            End If
                        Next
                    Next
                Next
            Next
            Wb.Save
            App.Quit
        End If
        Dim Proc As New Process
        Proc.File = ("E:\\快盘\\excel" & y & "\\汇总单表" & y & "0" & m & ".xls")
        Proc.Start()
    End If
End If