वीबीए विधि एक्सेल को

Question

के आधार पर अन्य पंक्तियों पर कोशिकाओं को स्थानांतरित करने के लिए एक्सेल में एक वीबीए विधि के साथ संघर्ष कर रहा हूं। मेरे पास एक सीएसवी है जिसे उत्पाद की श्रेणी के आधार पर संपादित करने की आवश्यकता है।

सीएसवी इस तरह दिखता है:

परिणाम मैं हासिल करना चाहते हैं यह है:

यहाँ विधि मैंने लिखा है, मुझे लगता है कि मैं करीब हूं, लेकिन यह वांछित के रूप में काम नहीं कर रहा है।

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

मैं पंक्तियों के माध्यम से लूप चाहते और जाँच प्रत्येक प्रविष्टि नीचे दो पंक्तियों हैं या नहीं तब जनसंख्या को अंतिम आबादी वाले मूल्य में प्रवेश का मूल्य निर्धारित करें। फिर आप मान को कई कॉलम में रखने के लिए इस मान को विभाजित कर सकते हैं।

युक्ति: जब कोशिकाओं के माध्यम से लूपिंग और पंक्तियों को हटाने के दौरान आप हमेशा नीचे से शुरू करना चाहते हैं और शीर्ष पर अपना रास्ता काम करना चाहते हैं।

इस प्रयास करें:

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

आप पिछले 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 

छवियों ब्लॉक किए गए हैं, जहां मैं अब कर रहा हूँ, तो कॉलम कुछ समायोजन की आवश्यकता हो सकती है