各行のセルの内容に基づいて行を新しいシートにコピーするVBA

Question

それでは、10,000行のコピーと編集を含むプロセスを自動化するための助けを期待しています。

これは位置情報に関するものです。基本的には、これらのマスター行は数多くありますが、ユニット番号の行は個別にありません。私は列Nにあるものに基づいて個々のユニット番号の行にこれらを展開する何かを得ることを望んでいます。列Nは、各行のコンマ区切りの単一セルリストである厳密なフォーマットに従うことを意図しています。

以下は、各行にどのようなものがあり、拡張する必要があるかのシート1の例です。 列Nは緑色であり、一貫した書式設定に従うことに注意してください。これは、これらの行が何回展開されるかの決定要因になります。以下は

シート2と私はVBAがシート1から作成したいです。 列Nシート1の内容に基づいて各行が拡張されていることがわかります。

私が言ったように、これには数千の行が作成されることが予想されます。

Answer 1

Option Explicit 

Sub Tester() 

    Dim sht1, sht2, rwSrc As Range, rwDest As Range, v, arr, n 

    Set sht1 = ThisWorkbook.Sheets("Sheet1") 
    Set sht2 = ThisWorkbook.Sheets("Sheet2") 

    sht2.Range("A2:M2").Resize(3, 13).Value = sht1.Range("A2:M2").Value 

    Set rwDest = sht2.Range("A2:M2") 'destination start row 
    Set rwSrc = sht1.Range("A2:M2") 'source row 

    Do While Application.CountA(rwSrc) > 0 

     v = rwSrc.EntireRow.Cells(1, "N").Value 'list of values 

     If InStr(v, ",") > 0 Then 
      'list of values: split and count 
      arr = Split(v, ",") 
      n = UBound(arr) + 1 
     Else 
      'one or no value 
      arr = Array(v) 
      n = 1 
     End If 

     'duplicate source row as required 
     rwDest.Resize(n, 13).Value = rwSrc.Value 

     'copy over the unit values 
     rwDest.Cells(1, "G").Resize(n, 1).Value = Application.Transpose(arr) 

     'offset to next destination row 
     Set rwDest = rwDest.Offset(n, 0) 

     'next source row 
     Set rwSrc = rwSrc.Offset(1, 0) 

    Loop 

End Sub 

Answer 2

これは、同じシートで作業を行います... plsはこれを実行する前の値に「シート2」をコピーしてください。確かに効率についてはわからない。

Public Sub Test() 


    Dim lr As Long   ' To store the last row of the data range 
    Dim counter As Long 
    Dim Str As String  ' To store the string in column N 


    lr = Range("N65536").End(xlUp).Row 'Getting the last row of the data 

    For i = lr To 2 Step -1 
     Str = Range("N" & i).Value  ' Getting the value from Column N 
     counter = 1 
     For Each s In Split(Str, ",") 
      If counter > 1 Then 
       Range("A" & (i + counter - 1)).EntireRow.Insert  ' Inserting rows for each value in column N 
       Range("G" & (i + counter - 1)).Formula = s   ' Updating the value in Column G 
      Else 
       Range("G" & i).Formula = s       ' No need to insert a new row for first value 
      End If 
      counter = counter + 1 

     Next s 
    Next i 


    lr = Range("G65536").End(xlUp).Row 

    ' Pulling down other values from the first value row other rows 
    Range("A1:N" & lr).Select 
    Selection.SpecialCells(xlCellTypeBlanks).Select 
    Selection.FormulaR1C1 = "=R[-1]C" 

    ' Pasting the data as Values to avoid future formula issues. 
    Range("A1:N" & lr).Copy 
    Range("A1:N" & lr).PasteSpecial xlPasteValues 

    MsgBox "Done" 




    End Sub