1

4列以上のデータがあり、最初の列「A」が日付列で、次の列「B、C、D」がデータです。週末の日付を検索して月曜日のデータに追加し、週末の日付とデータを全体のデータから削除するマクロを作成しようとしています。これはこれまでの私のコードです：

Sub NamedRange()

Dim Rng1 As Range
Dim newDate As Integer
Dim NumberOfRows As Range
Dim MyRange As Range
Dim lastRow2 As Variant
Set Rng1 = Sheets("Sheet1").Range("A1:A20")


Dim date1 As String
Dim dat As Date
Dim newPrice As Double


Set RgSales = Range("MyRange")
For i = 1 To RgSales.Rows.Count
For j = 1 To RgSales.Columns.Count

dat = RgSales.Cells(i, j)

date1 = WeekdayName(Weekday(dat))
    If (date1 = "Saturday" Or date1 = "Sunday") Then
        newDate = (RgSales.Cells(i + 1, j + 1).Value) + (RgSales.Cells(i, j + 1).Value)
        RgSales.Cells(i + 1, j + 1).Value = newDate
        newPrice = (RgSales.Cells(i + 1, j + 2).Value) + (RgSales.Cells(i, j + 2).Value)
        RgSales.Cells(i + 1, j + 2).Value = newPrice
        RgSales.Cells(i, j).Select
        Selection.Delete
        RgSales.Cells(i, j + 1).Select
        Selection.Delete
        RgSales.Cells(i, j + 2).Select
        Selection.Delete
End If
    Next j
    Next i
End Sub

Rangeに問題があります。データの最後の行で終了させたいだけです。マクロを実行した後、すべての

4

1 に答える 1

1

通常、範囲から行を削除するときは、逆方向にループする必要があります。行を削除すると、その下のすべての行が範囲に対して相対的に変更され (行 18 が行 17 になる)、カウンターが台無しになる可能性があります。これは、あなたが望むことをすると思う例です。

Sub ConsolidateWeekends()

    Dim i As Long
    Dim j As Long
    Dim rRng As Range
    Dim rCell As Range
    Dim rFound As Range
    Dim lDayOffset As Long

    'Define the range to consolidate
    Set rRng = Sheet3.Range("A1:A20")

    'Always loop backward when deleting rows or
    'the counter will get messed up
    For i = rRng.Rows.Count - 1 To 1 Step -1
        Set rCell = rRng.Cells(i, 1)

        'Define the offset that will return the Monday following the date
        If Weekday(rCell.Value) = vbSaturday Then
            lDayOffset = 2
        ElseIf Weekday(rCell.Value) = vbSunday Then
            lDayOffset = 1
        Else
            lDayOffset = 0
        End If

        If lDayOffset > 0 Then
            'Find the cell with the Monday in question
            Set rFound = rRng.Find(CDate(rCell.Value + lDayOffset), , xlValues, xlWhole)

            'if there is a cell with that Monday
            If Not rFound Is Nothing Then
                'Add the current dates B and C values to the Monday B and C values
                For j = 1 To 2
                    rFound.Offset(0, j).Value = rFound.Offset(0, j).Value + rCell.Offset(0, j).Value
                Next j
                'Delete the Sat or Sun row
                rCell.EntireRow.Delete
            End If
        End If
    Next i

End Sub
于 2012-07-25T18:31:04.893 に答える