2017-06-19 4 views
0

私は大量のデータをExcelで定期的に処理し、「スクラブ」するのは、印刷できない文字だけを含むセルを見つけてクリアすることです。VBAを使用して印刷できない文字だけを含むすべてのセルをすばやくクリアするにはどうすればよいですか?

明確にするために、クリアするマッチングセルの定義は、黒いフォントでフォーマットしたときに用紙にインクを印刷しないセルです。

これだけで細胞を含まれています

  • vbNullString、この式と同じ値:=「」
  • 空間の任意のタイプを(私は多くの異なる空白文字があることを、ハードな方法を見つけました。 )
  • タブ
  • 改行のいずれのタイプ
  • その他の非印字文字

良い答えを検討します:

  • ワークシートは、数百のセルのExcelデータと、何百万の行数千のを含んでいてもよいです。
  • クリアするマッチングセルには、複数の非印字文字が含まれることがあります。
  • ワークシートには、大きな範囲の空の範囲が含まれる場合があります。
  • 速度は大きな要因です。
  • 印刷可能な文字を含むセル内にある場合は、印刷できない文字を保持することが重要です。
  • 私が試してみました何

:ここ は、配列にワークシートのセルの値を保存する、これまでの私のコードだし、それらを介して160または以下に等しいのUnicode文字番号を探して一つずつループ私が知る限り、印字不可能な文字のほとんどまたはすべてをカバーする32。それは、単一の印刷不能な文字に等しいセルを見つけるだけである(すなわち、2つのスペースのみを含むセルが欠落する)。私のマシン上では、1秒間に約250,000個の細胞が走ります。

Public Sub EmptyAllBlankCells() 

    ' Get the last row in the worksheet 
    Dim maxRow As Long 
    maxRow = GetMaxCell.Row 

    ' Get the last column in the worksheet 
    Dim MaxCol As Byte 
    MaxCol = GetMaxCell.Column 

    ' Create an array of all worksheet cell values. 
    Dim arrData As Variant 
    ReDim arrData(0 To maxRow, 0 To MaxCol) 
    arrData = ActiveSheet.Range(Cells(1, 1), Cells(maxRow, MaxCol)) 

    ' Empty the contents of blank and whitespace only cells. 
    Dim iRow As Long 
    Dim iCol As Long 
    Dim iCellText As Variant ' or BYTE 
    For iRow = 1 To UBound(arrData, 1)     ' First array dimension is rows. 
     For iCol = 1 To UBound(arrData, 2)    ' Second array dimension is columns. 
      On Error Resume Next 
      iCellText = AscW(arrData(iRow, iCol)) 
      On Error GoTo 0 
      If iCellText <= 32 Or iCellText = 160 Then 
       ' Cell contains only a single non-printable character. 
       arrData(iRow, iCol) = Empty ' Empty the cell. 
      End If 
      iCellText = Empty 
     Next iCol 
    Next iRow 


    ' Write array back to worksheet. 
    Dim Destination As Range 
    Set Destination = Range("A1") 
    Destination.Resize(UBound(arrData, 1), UBound(arrData, 2)).Value = arrData 

End Sub 

Private Function GetMaxCell(Optional ByRef rng As Range = Nothing) As Range 
    'Returns the last cell containing a value, or A1 if Worksheet is empty 

    Const NONEMPTY As String = "*" 

    If rng Is Nothing Then Set rng = Application.ActiveWorkbook.ActiveSheet.UsedRange 
    If WorksheetFunction.CountA(rng) = 0 Then 
     Set GetMaxCell = rng.Parent.Cells(1, 1) 
    Else 
     Dim lRow As Range 

     With rng 
      Set lRow = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _ 
             After:=.Cells(1, 1), _ 
             SearchDirection:=xlPrevious, _ 
             SearchOrder:=xlByRows) 
      If Not lRow Is Nothing Then 

       Dim lCol As Range 
       Set lCol = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _ 
              After:=.Cells(1, 1), _ 
              SearchDirection:=xlPrevious, _ 
              SearchOrder:=xlByColumns) 

       Set GetMaxCell = .Parent.Cells(lRow.Row, lCol.Column) 

      End If 
     End With 

    End If 
End Function 

答えて

0

空白印刷不可能な文字の間にはかなり大きな違いがありますので、これは答えるために厄介な問題です。空白は基本的には表示されない文字(書式、スペースなど)のセットで、RegExの式で簡単に削除できます。印刷不可能な文字は、スクリーンやプリンタ、フォントなどのデバイス(「Device Context」とも呼ばれます)に依存するため、はるかに複雑な獣です(一部の値はフォントで表示されますが、別のフォントでは表示されません)。

印刷可能なグリフ(つまり、特定のデバイスと特定のフォント)のリストに本当にアクセスしたい場合は、その情報を抽出できるWindows APIsがあります。重要なのはGetFontUnicodeRanges()の機能です。これは、GLYPHSTRUCTUREとして知られている型を移入するため、VBAで使用する偽の関数です。この型には未知の次元の配列が含まれています.VBAでは、メモリを未知のサイズのデータ​​型に読み込むことはできません。したがって、データを取得するには、一種の反復メモリコピーが必要です。下のコードはどのように行うのかを示していますが、私がまだ32ビットであるという警告を追加する必要があります。これらのAPIを64ビット(かなり単純なタスク)に変換するにはgoogleにする必要があります。あなたのモジュールの上部に印刷可能なグリフのリスト

を取得

、以下のAPIを貼り付けます。同じモジュールで

Private Type WCRANGE 
    wcLow As Integer 
    cGlyphs As Integer 
End Type 
Private Type GLYPHSET 
    cbThis As Long 
    flAccel As Long 
    cGlyphsSupported As Long 
    cRanges As Long 
    ranges() As WCRANGE 
End Type 
Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, ByVal lpInitData As Any) As Long 
Private Declare Function CreateFont Lib "gdi32.dll" Alias "CreateFontA" (ByVal nHeight As Long, ByVal nWidth As Long, ByVal nEscapement As Long, ByVal nOrientation As Long, ByVal fnWeight As Long, ByVal fdwItalic As Long, ByVal fdwUnderline As Long, ByVal fdwStrikeOut As Long, ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As Long 
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hDC As Long, ByVal hObject As Long) As Long 
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long 
Private Declare Function GetFontUnicodeRanges Lib "gdi32.dll" (ByVal hDC As Long, pGLYPHSET As Any) As Long 
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDestination As Any, pSource As Any, ByVal lByteCount As Long) 

を、次の関数を貼り付けます。

Private Function GetPrintables(fontName As String, rejects As String) As Collection 
    Dim hDC As Long, hFont As Long, ret As Long, byteCount As Long 
    Dim b() As Byte 
    Dim i As Long, c As Long 
    Dim gs As GLYPHSET 
    Dim wc As WCRANGE 
    Dim printables As Collection 
    Dim rejectArray() As String 
    Dim v As Variant 
    Dim hit As Boolean 


    'Create a design context and font. 
    'Note: I've just used your screen context. Google if you want to use a printer. 
    hDC = CreateDC("DISPLAY", vbNullString, vbNullString, ByVal 0&) 
    hFont = CreateFont(0, 0, 0, 0, 400, 0, 0, 0, 1, 0, 0, 0, 0 Or 0, fontName) 
    ret = SelectObject(hDC, hFont) 

    'Find size of GLYPHSET structure. 
    byteCount = GetFontUnicodeRanges(hDC, ByVal 0&) 
    ReDim b(0 To byteCount - 1) 
    ret = GetFontUnicodeRanges(hDC, b(0)) 
    'Populate first 4 items of GLYPHSET 
    CopyMemory gs, b(0), LenB(gs) - LenB(wc) 
    'Populate .ranges array of GLYPHSET 
    ReDim gs.ranges(0 To gs.cRanges - 1) 
    i = LenB(gs) - LenB(wc) 
    For c = 0 To gs.cRanges - 1 
     CopyMemory gs.ranges(c), b(i), LenB(wc) 
     i = i + LenB(wc) 
    Next 

    'Delete the graphics objects 
    DeleteObject hFont 
    DeleteObject hDC 

    'Create the list of printable glyphs 
    rejectArray = Split(rejects, "|") 
    Set GetPrintables = New Collection 
    For c = 0 To gs.cRanges - 1 
     wc = gs.ranges(c) 
     For i = wc.wcLow To wc.wcLow + wc.cGlyphs - 1 
      'Ignore printable glyphs in our reject list 
      hit = False 
      For Each v In rejectArray 
       If i = CLng(v) Then 
        hit = True 
        Exit For 
       End If 
      Next 
      If Not hit Then GetPrintables.Add True, CStr(i) 
     Next 
    Next 
End Function 

必要に応じて独自のエラー処理を追加する必要があります。これには、APIの戻り値がre 0(失敗した関数を示す)。自分の価値観

のテスト

私はあなたはそれが簡単にあなたのテストのルールを逆に見つけるだろうと思います。言い換えれば、印刷できない文字だけを見るのではなく、印刷可能な文字の存在をテストしようとします。テストが真の場合、値は変更されません(あなたの投稿に従って)。だから、コードは、まだあなたのモジュールで、次のようになります。

Public Sub EmptyAllBlankCells() 
    Dim ws As Worksheet 
    Dim minCell As Range, maxCell As Range 
    Dim arrData As Variant 
    Dim printables As Collection 
    Dim rejects As String 
    Dim r As Long, c As Long, i As Long 
    Dim str As String, chr As String 
    Dim val As Long 
    Dim hit As Boolean 

    Set ws = Sheet1 
    Set minCell = ws.Cells(1, 1) 
    ' Get the last row in the worksheet 
    Set maxCell = GetMaxCell(ws.UsedRange) 

    ' Create an array of all worksheet cell values. 
    arrData = ws.Range(minCell, maxCell).Value2 

    'Acquire the list of printable characters. 
    rejects = "&H0020|&H00A0|&H1680|&H180E|&H2000|&H2001|&H2002|&H2003|&H2004|&H2005|&H2006|&H2007|&H2008|&H2009|&H200A|&H200B|&H202F|&H205F|&H3000|&HFEFF" 
    Set printables = GetPrintables(minCell.Font.Name, rejects) 

    ' Empty the contents of blank and whitespace only cells. 
    For r = 1 To UBound(arrData, 1)     ' First array dimension is rows. 
     For c = 1 To UBound(arrData, 2)    ' Second array dimension is columns. 
      If Not IsEmpty(arrData(r, c)) Then 
       str = CStr(arrData(r, c)) 
       hit = False 
       For i = 1 To Len(str) 
        chr = Mid(str, i, 1) 
        val = AscW(chr) 
        If val < 0 Then val = 65536 + val 
        On Error Resume Next 
        hit = printables(CStr(val)) 
        On Error GoTo 0 
        If hit Then Exit For 
       Next 
'    If Not hit Then arrData(r, c) = Empty 
       If Not hit Then arrData(r, c) = arrData(r, c) & "N" 
      End If 
     Next 
    Next 

    ' Write array back to worksheet. 
    ws.Range("A1").Resize(UBound(arrData, 1), UBound(arrData, 2)).Value = arrData 

End Sub 

あなたはrejectsという変数に気付くでしょう。これは単なる不要な印刷可能なグリフのリストです。サンプルコードでは、Unicodeスペースのリストです。

スピード

は、あなたは彼らがあなたの記事で示唆大きさだ場合は特に、配列にデータを読み込むことが正しいです。すばやく作業を続けるために、私はCollectionを使用しました。この文字には、印刷可能なグリフがすべて含まれていて、そのキーはユニコード値が文字列に変換されています。それはメモリ効率的ではありませんが、比較的高速です。

関連する問題