Question

我正在执行一项任务，其中以以下特定格式获取个人的日历：

Sheet1 A栏-日期 B栏-位置 C列-出发日期（文本格式2017年1月10日上午10:00） D列-到达日期（以文本格式2017年1月10日上午10:00） E栏-新位置 F列-注释

我需要执行的任务如下：

将Sheet1数据复制到Sheet2
在复制数据时，我需要根据以下条件插入行

如果C列出发日期和D列到达日期在同一天，则插入一个新行，其值如下：

A列-与上面的行相同的日期 B列-根据上述行从E列开始的新位置 C栏-空白 D列-空白 E栏-空白 F栏-空白

如果C列出发日期和D列到达日期是不同的日期，则无需插入行，并遵循与Sheet1中数据相同的顺序。

我使用了下面的代码，但是遇到了以下两个问题：

-此代码仅适用于Sheet1。您能帮我将其添加到Sheet2中吗，这样我可以将Sheet1包含原始数据，将Sheet2包含所需的结果？ -另外，以下代码使用文本“ INSERT”作为条件。我想将其更改为读取C列和D列，如果日期相同，则在日期下方添加一个新行。（请记住，C列和D列的文本格式是日期，因此我们可能必须使用我的朋友建议的左功能）

Private Sub CommandButton1_Click()

Dim wksData As Worksheet
Dim lngLastRow As Long, lngIdx As Long, _
lngDateCol As Long, _
lngReversalCol As Long, _
lngLocationCountryCol As Long, _
lngDestinationCountryCol As Long, _
lngDepartureDateCol As Long, _
lngArrivalDateCol As Long, _
lngNotesCol As Long

Dim varRowNum As Variant
Dim colRowNumsForInsert As Collection
Set colRowNumsForInsert = New Collection

'Set references up-front
lngDateCol = 1
lngLocationCountryCol = 2
lngDepartureDateCol = 3
lngArrivalDateCol = 4
lngDestinationCountryCol = 5
lngNotesCol = 6


Set wksData = ThisWorkbook.Worksheets("Sheet1")
lngLastRow = LastOccupiedRowNum(wksData)

'Loop through the data range BACKWARDS, tracking each case where a row will need to be in a collection
With wksData
    For lngIdx = lngLastRow To 2 Step -1

        'If the Notes Column = "INSERT", though, we also need 'to note that row number so we can eventually add a new row there
        If .Cells(lngIdx, lngNotesCol) = "INSERT" Then
            colRowNumsForInsert.Add Item:=lngIdx, Key:=CStr(lngIdx)
        End If

    Next lngIdx


    'Now we just need to add rows where necessary and apply the right values

    'Loop through the row numbers in our collection, which are conveniently in REVERSE order (as adding rows will change the row numbers in the range, making forward looping very difficult)
    For Each varRowNum In colRowNumsForInsert

        'First, insert a new row, shifting everything below it down
        .Range("A" & varRowNum).Offset(1).EntireRow.Insert Shift:=xlDown

        'Write the date (which are the same)
        .Cells(varRowNum + 1, lngDateCol) = .Cells(varRowNum, lngDateCol)

        'Write the new location (which is the new location from the row above)
        .Cells(varRowNum + 1, lngLocationCountryCol) = .Cells(varRowNum, lngDestinationCountryCol)
        .Cells(varRowNum, lngNotesCol) = ""
    Next varRowNum

End With

'Let the user know the script is done
MsgBox "Finished!"

End Sub


'INPUT       : Sheet, the worksheet we'll search to find the last row
'OUTPUT      : Long, the last occupied row
'SPECIAL CASE: if Sheet is empty, return 1

Public Function LastOccupiedRowNum(Sheet As Worksheet) As Long
Dim lng As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
    With Sheet
        lng = .Cells.Find(What:="*", _
                          After:=.Range("A1"), _
                          Lookat:=xlPart, _
                          LookIn:=xlFormulas, _
                          SearchOrder:=xlByRows, _
                          SearchDirection:=xlPrevious, _
                          MatchCase:=False).Row
    End With
Else
    lng = 1
End If
LastOccupiedRowNum = lng

End Function

Answer 1

如果我很了解您的需求，那应该可以：

Sub Santhosh()
    Dim lastRow, i As Long

    Sheets(2).Range("A1:E1").Value = Sheets(1).Range("A1:E1").Value

    lastRow = Sheets(1).Cells(Sheets(1).Rows.Count, "A").End(xlUp).Row
    For i = 2 To lastRow
        If Left(Sheets(1).Range("C" & i).Value, 11) = Left(Sheets(1).Range("D" & i).Value, 11) Then
            Sheets(2).Range("A" & i).Value = Sheets(1).Range("A" & i).Value
            Sheets(2).Range("B" & i).Value = Sheets(1).Range("E" & i).Value
        Else
            Sheets(2).Range("A" & i & ":E" & i).Value = Sheets(1).Range("A" & i & ":E" & i).Value
        End If
    Next
End Sub

VBA复制数据并根据条件插入行

1 个答案: