bugfix> excel > 投稿

この問題はVBAに関連しています。データのコピーと貼り付けを行います(一意の値、書式設定、空白の除外)。

私が持っているもの: 異なるヘッダーを持つ1枚のシート(DB)に、以下のデータがあります(数字、文字列、または空白にすることができます)

私が欲しいもの: 別のシート(宛先)に、データソースの一部の列の一意の値を持ちますが、データの書式設定と空白はありません。

私のアイデア:

  1. コピー DBシートに必要な特定の列とペースト 宛先シートに(特定の列も)。常に送信元の1列から送信先の1列に続きます。値として貼り付けます。
  2. 宛先シートで列を選択し、重複を削除
  3. 宛先シートで列を選択し、空白を削除する (また昇順ソート 空白が最後に移動するので機能します)

コード:

Sub Clean_Data()
Dim arr1, arr2, i As Integer
Dim LastNRow As Long
'Get the last used cell within the sheet (column in use A to L only) in order to capture the last row
With Sheets("DB")
    If Application.WorksheetFunction.CountA(.Cells) <> 0 Then 'Select the Column Range below
        LastNRow = .Range("A:L").Find(What:="*", _
              After:=.Range("A1"), _
              Lookat:=xlPart, _
              LookIn:=xlFormulas, _
              SearchOrder:=xlByRows, _
              SearchDirection:=xlPrevious, _
              MatchCase:=False).Row
    Else
        LastNRow = 1 'This won't ever happen
End If
    arr1 = Array("A", "B", "C", "D", "G", "H", "I", "J", "L") 'copy these columns in DB
    arr2 = Array("A", "D", "G", "J", "M", "P", "S", "V", "Y") 'paste into these columns in Destination
    For i = LBound(arr1) To UBound(arr1)
        With Sheets("DB")    
            .Range(.Cells(2, arr1(i)), .Cells(LastNRow, arr1(i))).Copy
            Sheets("Destination").Range(arr2(i) & 3).PasteSpecial Paste:=xlPasteValues
        End With
    Next
'remove the duplicates
    For i = LBound(arr2) To UBound(arr2)
        With Sheets("Destination")
            .Range(.Cells(3, arr2(i)), .Cells(LastNRow, arr1(i))).RemoveDuplicates Columns:=Array(1), Header:=xlNo
        End With
     Next
'remove the blank (I tried to use the sorting methodology as I couldn't figure out any code to remove the blanks/empty)
    For i = LBound(arr2) To UBound(arr2)
        With Sheets("Destination")
            .Range(.Cells(2, arr1(i)), .Cells(LastNRow, arr1(i))).Sort key1:=Array(1), order1:=xlAscending, Header:=xlNo
        End With
    Next
    Application.CutCopyMode = False
    End With
End Sub

問題点: 

  1. 空白の削除/空のコードは機能していません(昇順の並べ替え方法を採用しようとしました)が、それでも何が問題なのかわかりませんでした。
  2. 同じコードグループで重複を削除してソートする方法はありますか? 「With」および「End With」を再度開く代わりに。

お時間を割いて、ありがとうございます。

同様のことをしようとしている他の誰かに役立つ可能性があるため、すべてのコードを含めました。

すてきな一日を

回答 1 件
  • コードにはいくつかの問題がありました。

    1)範囲から空白セルを削除するためにソートを使用しないでください。 Excelにはそのためのネイティブ関数があります。

    2)アレイに読みやすい名前を付けて、ソースシートと宛先シートを混同しないようにします。

    3)ドキュメントに書き込むときは、 ScreenUpdating を設定します   False へ 、したがって、コードはより速く実行されます。

    これは私のために働く:

    Sub removeDuplicatesAndBlankCells()
        Dim i As Long, LastNRow As Long
        Dim tmpRng As Range
        Dim arrDestSheet As Variant, arrSourceSheet As Variant
        Application.ScreenUpdating = False
        'Get the last used cell within the sheet (column in use A to L only) in order to capture the last row
        With Sheets("DB")
            If Application.WorksheetFunction.CountA(.Cells) <> 0 Then 'Select the Column Range below
                LastNRow = .Range("A:L").Find(What:="*", _
                      After:=.Range("A1"), _
                      Lookat:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).Row
            Else
                LastNRow = 1 'This won't ever happen
        End If
        arrSourceSheet = Array("A", "B", "C", "D", "G", "H", "I", "J", "L") 'copy these columns in DB
        arrDestSheet = Array("A", "D", "G", "J", "M", "P", "S", "V", "Y") 'paste into these columns in Destination
        ' copy column content
        For i = LBound(arrSourceSheet) To UBound(arrSourceSheet)
            With Sheets("DB")
                .Range(.Cells(2, arrSourceSheet(i)), .Cells(LastNRow, arrSourceSheet(i))).Copy
                Sheets("Destination").Range(arrDestSheet(i) & 3).PasteSpecial Paste:=xlPasteValues
            End With
        Next
         ' remove blank cells
        For i = LBound(arrDestSheet) To UBound(arrDestSheet)
            With Sheets("Destination")
                Set tmpRng = .Range(.Cells(2, arrDestSheet(i)), .Cells(LastNRow, arrDestSheet(i)))
                tmpRng.SpecialCells(xlCellTypeBlanks).Delete
            End With
        Next
        ' remove duplicates
        For i = LBound(arrDestSheet) To UBound(arrDestSheet)
            With Sheets("Destination")
                .Range(.Cells(2, arrDestSheet(i)), .Cells(LastNRow, arrDestSheet(i))).removeDuplicates Columns:=Array(1), Header:=xlNo
            End With
        Next
        End With
        With Application
            .CutCopyMode = False
            .ScreenUpdating = True
        End With
    End Sub
    
    

あなたの答え