VBAコードの最適化 - 常駐住所の組み合わせ

Question

私は次の2つのVBAコードをExcelで行っています。主な目的は、複数のアドレス行を1行にまとめることです。問題は永遠に実行することです。とにかく私はそれを最適化することができますか？

データはそのままですが、顧客の住所ごとにケース＃があります。得意先住所は複数の行に分割することができます。例：「アドレス行1-ブロック56」、「住所行2-パリーアベニュー」、「住所行3-郵便番号」。新しいアドレスの間に空白があります。

私の目的は、アドレスを1行にまとめ、ケース番号の間の空の行を削除することです（例： "Block 56 Parry Avenue Postal code"）。約26Kのケース番号があります。

Sub test() 


Dim l As Long 
Dim lEnd As Long 
Dim wks As Worksheet 
Dim temp As String 

Application.EnableEvents = False 
Application.ScreenUpdating = False 

Set wks = Sheets("data") 
wks.Activate 

lEnd = ActiveSheet.UsedRange.Rows.Count 

For l = 3 To lEnd 
    If Not IsEmpty(Cells(l, 1)) Then 
      Do Until IsEmpty(Cells(l + 1, 4)) 
       temp = Cells(l, 4).Value & " " & Cells(l + 1, 4).Value 
       Cells(l, 4).Value = temp 
       Cells(l + 1, 4).EntireRow.Delete 
      Loop 

    Else: Cells(l, 1).EntireRow.Delete 
      Do Until IsEmpty(Cells(l + 1, 4)) 
       temp = Cells(l, 4).Value & " " & Cells(l + 1, 4).Value 
       Cells(l, 4).Value = temp 
       Cells(l + 1, 4).EntireRow.Delete 
      Loop 
    End If 


Next l 

End Sub 

はと第二のコードでは、私は

Sub transformdata() 
' 
Dim temp As String 

Application.ScreenUpdating = False 
Application.Calculation = xlCalculationManual 

Range("A3").Select 

Do Until IsEmpty(ActiveCell) And IsEmpty(ActiveCell.Offset(1, 0)) 
    Do Until IsEmpty(ActiveCell.Offset(1, 3)) 
      temp = ActiveCell.Offset(, 3).Value & " " & ActiveCell.Offset(1, 3).Value 
      ActiveCell.Offset(, 3).Value = temp 
      ActiveCell.Offset(1, 3).EntireRow.Delete 
    Loop 

    ActiveCell.Offset(1, 0).EntireRow.Delete 
    ActiveCell.Offset(1, 0).Select 

    Loop 

Application.ScreenUpdating = True 
Application.Calculation = xlCalculationAutomatic 


End Sub 

Answer 1

1. 変更ラインlEnd = ActiveSheet.UsedRange.Rows.Countを試してみました。最後の行を見つける方法が間違っています。 This
2. Cells(l, 1)が空の行を削除するには、オートフィルタを使用します。 This
3. ストレートループ内の行を削除しないでください。逆のループを使用します。または、ループ内で削除したいセルを特定し、ループの後に削除するセルを削除することができます。あなたは見たいかもしれません​​

これは基本的な例です。

のワークシートは、この

のように見えますが、このコード

Sub test() 
    Dim wks As Worksheet 
    Dim lRow As Long, i As Long 
    Dim temp As String 

    Application.ScreenUpdating = False 

    Set wks = Sheets("data") 

    With wks 
     '~~> Find Last Row 
     lRow = .Range("C" & .Rows.Count).End(xlUp).Row 

     For i = lRow To 2 Step -1 
      If Len(Trim(.Range("C" & i).Value)) <> 0 Then 
       If temp = "" Then 
        temp = .Range("C" & i).Value 
       Else 
        temp = .Range("C" & i).Value & "," & temp 
       End If 
      Else 
       .Range("D" & i + 1).Value = temp 
       temp = "" 
      End If 
     Next i 
    End With 
End Sub 

を実行する場合は、この出力今

は単に実行されますとしましょうオートフィルタo Col Dが空の行を削除します:)私はすでにあなたに同じリンクを与えています。

Answer 2

以下のコードは、すべてのデータを配列にコピーし、整理して新しいワークシートに追加します。 COLUMNCOUNT =データを含む列の数を設定する必要があります。

Sub TransformData2() 
    Const COLUMNCOUNT = 4 
    Dim SourceData, NewData 
    Dim count As Long, x1 As Long, x2 As Long, y As Long 

    SourceData = Range("A" & Range("D" & Rows.count).End(xlUp).Row, Cells(3, COLUMNCOUNT)) 

    For x1 = 1 To UBound(SourceData, 1) 

     count = count + 1 
     If count = 1 Then 
      ReDim NewData(1 To 4, 1 To count) 
     Else 
      ReDim Preserve NewData(1 To 4, 1 To count) 
     End If 

     For y = 1 To UBound(SourceData, 2) 
      NewData(y, count) = SourceData(x1, y) 
     Next 

     x2 = x1 + 1 

     Do 
      NewData(4, count) = NewData(4, count) & " " & SourceData(x2, 4) 
      x2 = x2 + 1 
      If x2 > UBound(SourceData, 1) Then Exit Do 
     Loop Until IsEmpty(SourceData(x2, 4)) 
     x1 = x2 
    Next 

    ThisWorkbook.Worksheets.Add 
    Range("A1").Resize(UBound(NewData, 2), UBound(NewData, 1)).Value = WorksheetFunction.Transpose(NewData) 
End Sub