使用vbscript创建稀疏矩阵 [英] Sparse matrix creation using vbscript

问题描述

假设我有一个Array = {A，B，Y，X}。现在我有一个Excel表格，可以有动态列数和Rows.Say作为下面的例子：

输入：

  ColA ColC ColC .... 
 
 TPY .... 
 CYD .... 
 BAM .... 
 ZRX .... 
  

OutPut：

  ColA ColB ColC ... 。
 
  -   -  Y .... 
  -  Y  -  .... 
 BA  -  .... 
  -   -  X .... 
  

其中所有列只有Array值，如果找到其他任何值，则需要替换它们通过 -

除了比较慢的循环技术，使用VBscript有更快的过程吗？ / p>

谢谢，

解决方案

  Sub Macro1（）
 
 Dim arr，i，rng As Range 
 
 arr = Array（X，Y，Z）
设置rng = ActiveSheet.Range（A1）。CurrentRegion 
 
应用程序
 .ScreenUpdating = False 
 .Calculation = xlCalculationManual 
结束
 
对于i = LBound（arr）到UBound（arr） 
 rng.Replace什么：= arr（i），替换：= - ，LookAt：= xlWhole，_ 
 SearchOrder：= xlByRows，MatchCase：= True，SearchFormat：= False，_ 
 ReplaceFormat：= False 
下一个i 
 
应用程序
 .ScreenUpdating = True 
 .Calculation = xlCalculationAutomatic 
结束
 
 End Sub 
  

编辑：

  Sub KeepValues（）
 
 Dim arr，arrVals，i，rng As Range，r，c 
 Dim keepval As Boolean 
 
 arr = Array（X，Y，Z）
 
设置rng = ActiveSheet.Range（A1）CurrentRegion 
 arrVals = rng.Value 
 
对于r = 1到UBound（arrVals，1）
对于c = 1到UBound（arrVals，2）
 keepval = False 
对于i = LBound（arr）到UBound （arr）
如果arr（i）= arrVals（r，c）然后
 keepval = True 
退出
结束If 
下一个i 
如果不保留然后arrVals（r，c）=
下一个c 
下一个r 
 
 rng.Value = arrVals 
 
 End Sub 
  

Suppose I have an Array={A,B,Y,X}. Now I do have an Excel sheet which can have dynamic number of columns and Rows.Say as an example below :

Input:

ColA   ColB   ColC  ....

 T      P      Y    ....
 C      Y      D    ....
 B      A      M    ....
 Z      R      X    ....

OutPut:

ColA   ColB   ColC  ....

 -      -      Y    ....
 -      Y      -    ....
 B      A      -    ....
 -      -      X    ....

Where all the columns will have only the Array values,if any other values are found they are required to be replaced by "-"

Is there any faster process to do these using VBscript except comparatively slow looping technique?

Thanks,

解决方案

Sub Macro1()

    Dim arr, i, rng As Range

    arr = Array("X", "Y", "Z")
    Set rng = ActiveSheet.Range("A1").CurrentRegion

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    For i = LBound(arr) To UBound(arr)
        rng.Replace What:=arr(i), Replacement:="-", LookAt:=xlWhole, _
            SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
            ReplaceFormat:=False
    Next i

    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With

End Sub

EDIT:

Sub KeepValues()

    Dim arr, arrVals, i, rng As Range, r, c
    Dim keepval As Boolean

    arr = Array("X", "Y", "Z")

    Set rng = ActiveSheet.Range("A1").CurrentRegion
    arrVals = rng.Value

    For r = 1 To UBound(arrVals, 1)
        For c = 1 To UBound(arrVals, 2)
            keepval = False
            For i = LBound(arr) To UBound(arr)
                If arr(i) = arrVals(r, c) Then
                    keepval = True
                    Exit For
                End If
            Next i
            If Not keepval Then arrVals(r, c) = ""
        Next c
    Next r

    rng.Value = arrVals

End Sub

这篇关于使用vbscript创建稀疏矩阵的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！