desagree dans Excel

Question

J'ai besoin de votre aide dans ce cas:

Je:

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 

et je veux:

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 

vous pouvez me aider à faire cette macro? J'ai écrit 5 colonnes mais j'ai besoin de la macro pour 20 colonnes mais le meilleur sera que je peux choisir le nombre de colonnes dans la macro.

Son près que cette affaire mais avec plusieurs colonnes: Excel Macro - Comma Separated Cells to Rows Preserve/Aggregate Column

Merci!

Answer 1

Ce code doit être ce que vous cherchez, la méthode ExpandData(String, String, String) prend la colonne de départ pour l'ensemble des données (dans ce cas, « A ») pour le premier paramètre, la colonne de fin pour l'ensemble de données copier en tant que deuxième paramètre (dans ce cas "D") et enfin la colonne avec l'ensemble des données séparées par des virgules ("E" ici).

Vous devriez probablement l'étendre pour qu'il prenne aussi une ligne de départ ou en fasse simplement une formule addin où il faut une plage et une colonne.

Espérons que cela aide.

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

Je ne connais pas beaucoup VBA, donc vous devrez comprendre cela par vous-même. Cependant, j'utiliserais Text to Columns pour convertir la section CSV en colonnes individuelles, puis une option Collage spécial avec l'option Transposer pour transformer les colonnes a b c en lignes.

Answer 3

Voici quelques notes.

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