desagree in Excel

Question

Ich brauche Ihre Hilfe in diesem Fall:

ich habe:

1 11 111 Cat1 a,b,c 

2 22 222 Cat2 d 

3 33 333 Cat3 e,f 

4 44 444 Cat4 g,h,i 

und ich will:

1 11 111 Cat1 a 

1 11 111 Cat1 b 

1 11 111 Cat1 c 

2 22 222 Cat2 d 

3 33 333 Cat3 e 

3 33 333 Cat3 f 

4 44 444 Cat4 g 

4 44 444 Cat4 h 

4 44 444 Cat4 i 

Sie können mir helfen, diesen Makro zu machen? Ich habe 5 Spalten geschrieben, aber ich brauche das Makro für 20 Spalten, aber das Beste wird sein, dass ich die Anzahl der Spalten im Makro wählen kann.

Seine nahe, dass dieser Fall aber mit mehr Spalten: Excel Macro - Comma Separated Cells to Rows Preserve/Aggregate Column

Dank!

Answer 1

sollten Dieser Code sein, was Sie suchen, nimmt das Verfahren ExpandData(String, String, String) die Startspalte für den Satz von Daten (in diesem Fall „A“) für den ersten Parameter, die End-Spalte für den Satz von Daten als zweiten Parameter kopieren (in diesem Fall "D") und schließlich die Spalte mit dem Datensatz, der durch Komma getrennt ist (hier "E").

Sie sollten es wahrscheinlich erweitern, so dass es auch eine Startzeile oder einfach eine AddIn Formel Sache, wo es einen Bereich und eine Spalte dauert.

Hoffe, das hilft.

Sub ExpandDat() 
    ExpandData "A", "D", "E" 
End Sub 

Sub ExpandData(start_range As String, end_range As String, comma_column As String) 
    Const FirstRow = 1 
    Dim LastRow As Long 
    LastRow = Range(start_range & CStr(Rows.Count)).End(xlUp).Row 

    ' Get the values from the worksheet ' 
    Dim SourceRange As Range 
    Set SourceRange = Range(start_range & CStr(FirstRow) & ":" & end_range & CStr(LastRow)) 

    ' Get the comma seperated values as a different set of values ' 
    Dim CommaRange As Range 
    Set CommaRange = Range(comma_column & CStr(FirstRow) & ":" & comma_column & CStr(LastRow)) 

    ' Get the values from the actual values ' 
    Dim Vals() As Variant 
    Vals = SourceRange.Value 

    ' We need to know the upper and lower bounds of the second dimension in the Vals Array ' 
    Dim lower As Integer 
    Dim upper As Integer 
    lower = LBound(Vals, 2) 
    upper = UBound(Vals, 2) 

    ' Get the comma seperated values ' 
    Dim Commas() As Variant 
    Commas = CommaRange.Value 

    ' Loop through the rows in the array and split each comma-delimited list of items and put each on its own row ' 
    Dim ArrIdx As Long 
    Dim RowCount As Long 
    For ArrIdx = LBound(Commas, 1) To UBound(Commas, 1) 

     Dim CurrList As String 
     CurrList = Replace(Commas(ArrIdx, 1), " ", "") 

     ' Split the Comma set into an array ' 
     Dim ListItems() As String 
     ListItems = Split(CurrList, ",") 

     ' For each value in the Comma Seperated values write the output ' 
     Dim ListIdx As Integer 
     For ListIdx = LBound(ListItems) To UBound(ListItems) 
      ' Loop through the values in our source range and output them ' 
      For Idx = lower To upper 
       Range(start_range & CStr(FirstRow + RowCount)).Offset(0, Idx - 1).Value = Vals(ArrIdx, Idx) 
      Next Idx 

      Range(comma_column & CStr(FirstRow + RowCount)).Value = ListItems(ListIdx) 
      RowCount = RowCount + 1 

     Next ListIdx 

    Next ArrIdx 

End Sub 

Answer 2

Ich weiß nicht viel VBA, also müssen Sie das selbst herausfinden. Allerdings würde ich Text to Columns verwenden, um den CSV-Abschnitt in einzelne Spalten zu konvertieren, und dann ein Paste Special mit der Option Transpose, um die Spalten a b c in Zeilen umzuwandeln.

Answer 3

Hier sind einige Hinweise.

Sub SplitRows() 
strFile = Workbooks(1).FullName 
strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile _ 
    & ";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";" 

Set cn = CreateObject("ADODB.Connection") 
Set rs = CreateObject("ADODB.Recordset") 
Set rss = CreateObject("ADODB.Recordset") 

cn.Open strCon 

strSQL = "SELECT * FROM [Sheet4$]" 

rs.Open strSQL, cn 

For i = 0 To rs.Fields.Count - 1 
    If Not IsNumeric(rs.Fields(i)) Then 
     rss.Fields.Append rs.Fields(i).Name, adVarWChar, 255 
    Else 
     rss.Fields.Append rs.Fields(i).Name, adInteger 
    End If 
Next 

rss.Open 

Do While Not rs.EOF 
    cat = Split(rs.Fields(3), " ") 
    a = Split(cat(1), ",") 
    For i = 0 To UBound(a) 

     rss.AddNew 

     For j = 0 To rs.Fields.Count - 1 
      If j = 3 Then 
       rss(j) = cat(0) & " " & a(i) 
      Else 
       rss(j) = rs(j) 
      End If 
     Next 

     rss.Update 

    Next 
    rs.MoveNext 
Loop 

rss.MoveFirst 
Worksheets("Sheet5").Cells(2, 1).CopyFromRecordset rss 

End Sub