VBA yöntemi excel'i başka bir satıra taşıyabilir.

Question

excel'de bir VBA yöntemi ile uğraşıyorum. Ürün kategorisine göre düzenlenmesi gereken bir CSV var.

csv şuna benzer:

elde etmek istediğiniz sonuç şudur: Burada

Yazdığım Yöntem olduğu; Sanırım yakınım ama istediği gibi çalışmıyor. Orada tamamen boş olan CSV bazı satırlar, bu nedenle bu yanı üzerinde düşünülmesi gereken

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 

..

Answer 1

Ben satırlar arasında döngü olur ve her girişin altındaki iki sıra olup olmadığını kontrol Daha sonra, girdinin değerini son doldurulmuş değerine ayarlayın. Daha sonra değerleri birden çok sütuna koymak için bu değeri bölebilirsiniz.

İpucu: Hücreler arasında geçiş yaparken ve satırları silerken her zaman en alttan başlamak ve en üstte çalışmak istiyorsunuz.

bu deneyin:

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

Bu sütunu bölmek son 2 sütun taşımak ve sütunlara Metin kullanabilirsiniz:

şimdi nerede görüntüleri engellenir

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 

, böylece sütunlar Bazı ayarlamalar