一些vsto小程序

sscylh

       刚刚开始学vsto,可以编一些小程序(虽然类啊,对象啊.class啊,继承啊什么的还不懂.而这些又是vsto强大之处...)

把这两天回复的关于vsto的程序整理到一个帖子,或许对其他人有一点点点点(此处省略无穷个点...)用,高手勿喷(所谓闻道有先后是也)

1:   texttocolumns:
http://club.excelhome.net/forum.php?mod=redirect&goto=findpost&ptid=906742&pid=6481294

源码:

1. 
   
2. Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
   
3.         Dim endrow As Integer
   
4.         Dim str As String
   
5.         endrow = Me.Range("a65536").End(Excel.XlDirection.xlUp).Row
   
6.         Range("a1:a" & endrow).TextToColumns(Range("c1"), Excel.XlTextParsingType.xlDelimited, Excel.XlTextQualifier.xlTextQualifierDoubleQuote, , , , True)
   
7. End Sub

复制代码

2:    http://club.excelhome.net/forum.php?mod=redirect&goto=findpost&ptid=910633&pid=6481278

源码:

1. Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
   
2.         Dim endrow As Integer
   
3.         Dim str As String
   
4.         endrow = Me.Range("a65536").End(Excel.XlDirection.xlUp).Row
   
5.         For i As Integer = 1 To endrow
   
6.             For j As Integer = 1 To Len(Range("a" & i).Value)
   
7.                 str &= "!" & Mid(Range("a" & i).Value, j, 1)
   
8.             Next
   
9.             Range("a" & i).Value = str
   
10.             str = ""
    
11.         Next
    
12.     End Sub

复制代码

3:    字典  http://club.excelhome.net/forum.php?mod=redirect&goto=findpost&ptid=919100&pid=6481268
源码:

1. Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
   
2.         Dim rng As Excel.Range = Me.Range("a1")
   
3.         Dim arr As Array
   
4.         arr = Split(rng.Value, " ")
   
5.         Dim rng2 As Excel.Range = Me.Range("a2")
   
6.         Dim brr() As String
   
7.         brr = Split(rng2.Value, " ")
   
8.         Array.Sort(arr)
   
9.         For i = 0 To UBound(brr)
   
10.             If Array.BinarySearch(arr, brr(i)) >= 0 Then
    
11.                 rng2.Characters(InStr(rng2.Value, brr(i)), brr(i).Length).Font.ColorIndex = Int(Rnd() * 20)
    
12.             End If
    
13.         Next
    
14.     End Sub

复制代码

5: 依然是 array.binarysearch
  http://club.excelhome.net/forum.php?mod=redirect&goto=findpost&ptid=901951&pid=6481127

1. Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
   
2.         Dim rng As Excel.Range = Me.Range("a1")
   
3.         Dim arr As Array
   
4.         arr = Split(rng.Value, " ")
   
5.         Dim rng2 As Excel.Range = Me.Range("a2")
   
6.         Dim brr() As String
   
7.         brr = Split(rng2.Value, " ")
   
8.         Array.Sort(arr)
   
9.         For i = 0 To UBound(brr)
   
10.             If Array.BinarySearch(arr, brr(i)) >= 0 Then
    
11.                 rng2.Characters(InStr(rng2.Value, brr(i)), brr(i).Length).Font.ColorIndex = Int(Rnd() * 20)
    
12.             End If
    
13.         Next
    
14.     End Sub

复制代码

6:     在vba中,为避免反复读取单元格值降低运行速度,会将单元格区域赋值给数值.
       而在vsto中,同样是这样子的,赋值方式差不多一样
http://club.excelhome.net/forum.php?mod=redirect&goto=findpost&ptid=945411&pid=6480689

1. Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
   
2.         Dim endrow As Integer
   
3.         Dim sht As Excel.Worksheet = Me.Application.ActiveWorkbook.Sheets(1)
   
4.         endrow = sht.Range("a65536").End(Excel.XlDirection.xlUp).Row
   
5.         Dim soucerng As Excel.Range = sht.Range("a1:c" & endrow)
   
6.         Dim arr
   
7.         arr = soucerng.Value
   
8.         Dim find As String = Me.Range("a2").Value
   
9.         For i As Integer = 1 To endrow
   
10.             If arr(i, 1) = find Then
    
11.                 Me.Range("b2").Value = arr(i, 2)
    
12.                 Me.Range("c2").Value = arr(i, 3)
    
13.                 Exit For
    
14.             End If
    
15.         Next
    
16.     End Sub

复制代码

7:    删除工作表(array.binarysearch)
http://club.excelhome.net/forum.php?mod=redirect&goto=findpost&ptid=822255&pid=6480633

1. Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
   
2.         Dim arr As Array = Array.CreateInstance(GetType(String), 2)
   
3.         Me.Application.DisplayAlerts = False
   
4.         arr.SetValue("Sheet1", 0)
   
5.         arr.SetValue("Sheet2", 1)
   
6.         For Each ws As Excel.Worksheet In Me.Application.ActiveWorkbook.Worksheets
   
7.             If Array.BinarySearch(arr, ws.Name) < 0 Then
   
8.                 ws.Delete()
   
9.             End If
   
10.         Next
    
11.         Me.Application.DisplayAlerts = True
    
12.     End Sub

复制代码

8:   设置单元格背景色
  http://club.excelhome.net/forum.php?mod=redirect&goto=findpost&ptid=945302&pid=6479748

1. Private Sub Sheet1_SelectionChange(ByVal Target As Microsoft.Office.Interop.Excel.Range) Handles Me.SelectionChange
   
2.         If Left(Target.Address, 2) <> "$B" Or Len(Target.Value) > 0 Then
   
3.             Target.Interior.ColorIndex = Excel.XlColorIndex.xlColorIndexNone
   
4.         Else
   
5.             Target.Interior.ColorIndex = 12
   
6.         End If
   
7.     End Sub

复制代码

9:   vsto操作文本文件(filesystem)
http://club.excelhome.net/forum.php?mod=redirect&goto=findpost&ptid=945274&pid=6479664

1. Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
   
2.         Dim writer = My.Computer.FileSystem.OpenTextFileWriter("e:/123.txt", True)
   
3.         For i As Integer = 1 To 10
   
4.             For j As Integer = 1 To 5
   
5.                 writer.WriteLine(Cells(i, j).value)
   
6.             Next
   
7.         Next
   
8.         writer.Close()
   
9.     End Sub

复制代码

10: 数据类型对运算速度的影响:
http://club.excelhome.net/forum.php?mod=redirect&goto=findpost&ptid=945074&pid=6478147

1. 相同一程序:
   
2. 以下为测试结果:
   
3. 改为single(占4个字节):7秒
   
4. 改为double(8个字节):17秒
   
5. 改为dicimal(16个字节):37秒
   
6. 改为integer(4个字节):7秒
   
7. 改为short(2个字节):3秒
   
8. 看来数据类型在vb.net中对运算速度有巨大影响!
   

复制代码

11:还是字典,刚编此程序时不知道如何将dim arr as array=array.createinstance(gettype(integer)),dic.count) ,  dic.keys.copyto (arr,0)此用法,用的是循环
http://club.excelhome.net/forum.php?mod=redirect&goto=findpost&ptid=943863&pid=6473273

1. Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
   
2.         Dim dic As New Dictionary(Of Integer, Integer)
   
3.         Dim kk As Integer
   
4.         Dim brr()
   
5.         Dim crr()
   
6.         For i = 1 To 16
   
7.             If dic.ContainsKey(Me.Range("a" & i).Value) Then
   
8.                 dic(Me.Range("a" & i).Value) = dic(Me.Range("a" & i).Value) + Range("b" & i).Value
   
9.             Else
   
10.                 dic(Me.Range("a" & i).Value) = Me.Range("b" & i).Value
    
11.             End If
    
12.         Next
    
13.         Dim keys As Dictionary(Of Integer, Integer).KeyCollection = dic.Keys
    
14.         For Each s As Integer In keys
    
15.             kk = kk + 1
    
16.             ReDim Preserve brr(kk - 1)
    
17.             brr(kk - 1) = s
    
18.         Next
    
19.         MsgBox(Join(brr, ","))
    
20.         kk = 0
    
21.         Dim values As Dictionary(Of Integer, Integer).ValueCollection = dic.Values
    
22.         For Each s As Integer In values
    
23.             kk = kk + 1
    
24.             ReDim Preserve crr(kk - 1)
    
25.             crr(kk - 1) = s
    
26.         Next
    
27.         MsgBox(Join(crr, ","))
    
28.     End Sub

复制代码

12:  待续

sscylh

抢个二楼,待补充.

vs2010

还是比较喜欢用C#写 VB不熟了

xmhjf

楼主，继续补充，跟着你学习

星浩

好帖，收藏

風中的雨點

sscylh 发表于 2013-5-3 18:52
ME是在窗体里面用，指这个窗体，窗体当然没有range属性了，您大概是把ME当成sheet来有了。

me也有不表 ...

不太明白，先谢了。

風中的雨點

      endrow = Me.Range("a65536").End(Excel.XlDirection.xlUp).Row

怎么我会提示 Me.Range 错误呢？

sscylh

風中的雨點 发表于 2013-5-3 16:07
endrow = Me.Range("a65536").End(Excel.XlDirection.xlUp).Row

怎么我会提示 Me.Range 错误呢 ...

ME是在窗体里面用，指这个窗体，窗体当然没有range属性了，您大概是把ME当成sheet来有了。

me也有不表示窗体的时候，不过是在ppt里面，表示当前slide。

3dcapture

不错，跟着学到 不少知识。

Amas

感谢楼主分享。