用于复制去年行的宏,将复制的单元格插入到下面的行中,然后将年份更改为当前

时间:2014-01-22 10:17:03

标签: excel vba excel-vba

我有一个大型数据表(“数据”),其中有几个houndred行,在第一列中有多年(例如2013年12月31日),以及以下列中的各种数据。

我试图创建一个遍历A列的宏,并找到包含31.12.2013的每个单元格,并且其下面没有包含31.12.2014的单元格。它每次都应该复制整行,将复制的单元格插入其下面的新行,并将日期从2013年12月31日更改为2014年12月31日。

由于这是我第一次尝试制作宏,我不知道自己在做什么。这是我在混合了一些我在网上发现的代码和一些来自内置记录器的代码后得到的结果,希望有人可以做出实际上有用的东西:

    Sub Nyttaarsregnskap()

Dim searchSheet As Worksheet
Dim currentRow As Long
Dim lastRow As Long

Set searchSheet = Sheets("Data")

Application.ScreenUpdating = False


searchSheet.Activate
lastRow = searchSheet.Cells(Rows.Count, "A").End(xlUp).Row


For currentRow = 1 To lastRow
    If InStr(LCase(searchSheet.Cells(currentRow, "A")), "12/31/2013") > 0 Then
        If Not InStr(LCase(searchSheet.Cells(currentRow + 1, "A")), "12/31/2014") > 0 Then
            searchSheet.Rows(currentRow & ":" & currentRow).Copy
            Cells(currentRow + 1, "A").Select
            Selection.Insert Shift:=xlDown
            Application.CutCopyMode = False
            Cells(currentRow + 1, "A").FormulaR1C1 = "12/31/2014"
            lastRow = lastRow + 1
        End If
    End If
Next currentRow

End Sub

1 个答案:

答案 0 :(得分:0)

试试这个:

Sub Nyttaarsregnskap()

    Dim searchSheet As Worksheet
    Dim currentRow As Long
    Dim lastRow As Long

    Application.ScreenUpdating = False

    Set searchSheet = Sheets("Data")

    With searchSheet
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

        For currentRow = lastRow To 1 Step -1
            If Format(.Cells(currentRow, "A"), "mm/dd/yyyy") = Format("12/31/2013", "mm/dd/yyyy") Then
                If Not Format(.Cells(currentRow + 1, "A"), "mm/dd/yyyy") = Format("12/31/2014", "mm/dd/yyyy") Then
                    .Range(currentRow + 1 & ":" & currentRow + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                    .Rows(currentRow & ":" & currentRow).Copy .Cells(currentRow + 1, "A")
                    .Cells(currentRow + 1, "A").FormulaR1C1 = "12/31/2014"
                End If
            End If
        Next currentRow
    End With

    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub