VBAメソッドは、値に基づいて他の行にセルを移動するのに威力を発揮します

Question

私はExcelでVBAメソッドで苦労しています。私は製品のカテゴリに基づいて編集する必要があるCSVを持っています。

CSVは次のようになります。

私が達成したい結果がこれです：ここで

は、私が書いた方法です。私は近くにいると思うが、それはまだ望むように働いていない。

Sub test() 
    'c is a CELL or a range 
    Dim c As Range 

    'for each CELL in this range 
    For Each c In Range("A2", Cells(Cells.SpecialCells(xlCellTypeLastCell).Row, 1)) 

     'Als de cel leeg is en de volgende niet dan 
     If c = "" And c.Offset(1, 0) <> "" Then 
      'verplaats inhoud lege cel naar 1 boven 
      c.Offset(-1, 6) = c.Offset(0, 5) 
      'Verwijder rij 
      c.EntireRow.Delete  

     'Als de cel leeg is en de volgende ook dan 
     ElseIf c = "" And c.Offset(1, 0) = "" Then 
      'verplaats inhoud lege cel naar 1 boven 
      If c.Offset(0, 5) <> "" Then 
       c.Offset(-1, 6) = c.Offset(0, 5) 

      'Als inhoud 
      ElseIf c.Offset(1, 5) <> "" Then 
       c.Offset(-1, 7) = c.Offset(1, 5) 

      Else 
       c.EntireRow.Delete 
       c.Offset(1,0).EntireRow.Delete  
      End If 

     End If 
    Next 
End Sub 

あり、完全に空になっているCSVでのいくつかの行があるので、これも同様に検討する必要がある。..

Answer 1

が、私は行をループをいただきたいと、各エントリの下に2つの行があるかどうかを確認入力した値を最後に入力された値に設定します。この値を分割して、値を複数の列に入れることができます。

ヒント：セルをループして行を削除するときは、常に下から開始して上に向かって作業したいと考えています。

この試してみてください：あなたは、最後の2列を移動して、列を分割するために列にテキストを使用することができます

Sub test() 

Dim arr() as String 
Dim x As Long, i as long, lRow as long 

With ThisWorkbook.Sheets("SheetName") 
    lRow = .Cells(.Rows.Count, 1).End(xlUp).Row 

    'Insert 2 columns to hold the extra information 
    .Columns("E:F").Insert 

    For x = lRow to 2 Step -1 

     'Delete rows that are completely blank 
     If .Cells(x, "A").Value = "" And .Cells(x, "D").Value = "" Then 
      .Cells(x, "A").EntireRow.Delete 

     'Find the next entry 
     ElseIf .Cells(x, "A").Value <> "" Then 

      'Check if the 2nd row below the entry is populated 
      If .Cells(x + 2, "A").Value = "" And .Cells(x + 2, "D").Value <> "" Then 
       .Cells(x, "D").Value = .Cells(x + 2, "D").Value 
       .Range(.Cells(x + 2, "D"), .Cells(x + 1, "D")).EntireRow.Delete 

       'Split the strings using the "/" character, if there is also a space you will need to use "/ " instead, then populate the inserted columns 
       arr = Split(.Cells(x, "D").Value, "/") 
       For i = 0 to UBound(arr) 
        .Cells(x, 4 + i).Value = arr(i) 
       Next i 

      'If the 2nd row isn't populated only take the row below 
      ElseIf .Cells(x + 1, "A").Value = "" And .Cells(x + 1, "D").Value <> "" Then 
       .Cells(x, "D").Value = .Cells(x + 1, "D").Value 
       .Cells(x + 1, "D").EntireRow.Delete 

       'Split the strings using the "/" character, if there is also a space you will need to use "/ " instead, then populate the inserted columns 
       arr = Split(.Cells(x, "D").Value, "/") 
       For i = 0 to UBound(arr) 
        .Cells(x, 4 + i).Value = arr(i) 
       Next i 

      End If 

     End If 

    Next x 

End With 

End Sub 

Answer 2

を：私は今の私どこ

Sub test() ': Cells.Delete: [A1:F1,A3:F3] = [{1,2,3,"a/b/c",7,8}] ' used for testing 
    Dim rng As Range 
    Set rng = Sheet1.UsedRange     ' set the range here 

    rng.Columns("E:F").Cut 
    rng.Resize(, 2).Insert xlToRight ' move the last 2 columns 

    rng.Columns("D").TextToColumns OtherChar:="/" ' split the last column 

    rng.SpecialCells(xlCellTypeConstants).EntireRow.Hidden = True ' hide non-empty rows 
    rng.SpecialCells(xlCellTypeVisible).EntireRow.Delete ' delete visible rows 
    rng.EntireRow.Hidden = False ' un-hide the rows 

    Set rng = rng.CurrentRegion 
    rng.Resize(, 2).Cut ' move the 2 columns back to the end 
    rng.Resize(, 2).Offset(, rng.Columns.Count).Insert xlToRight 
End Sub 

画像がブロックされているので、列いくつかの調整が必要な場合があります