要复制的VBA代码;根据日期数据粘贴行

时间：2014-12-26 09:58:24

标签： excel-vba vba excel

我是VBA的新手，所以我会为你提供一些我希望实现的目标和目的。  我正在从另一个程序中复制数据（没有问题），然后我将它粘贴到一个工作表中，我已将编码传入数据的格式编码嵌套到我想要的位置（看起来很漂亮），我使用我创建的用户窗体粘贴（仍然没有问题）。 然后我创建了另一个UserForm并使用它来对数据进行日期范围之间的天数排序（使用VBA与公式），如果没有日期，那么我指定今天的日期（日期）以上所有工作都很棒。 我的问题是，当用户完成上述操作后，会弹出另一个UserForm，询问他们是否要将过期数据添加到报告表中，这应该复制任何在“G”列中具有今天日期（日期）的行，然后将其粘贴到报告表行“A1”向下

我很感激帮助，我已经尝试了一些选项并在网上搜索得很高，到目前为止它使用以下代码查看第7列，目前我有15个行项目要排序，其中两个有今天的日期。我只保留今天日期所需的两行中的最后一行，以便从数据表中粘贴到报告表中？

以下是到目前为止的完整代码以及您的附加代码（第一部分形成了目标表单，正如您所看到的，它确保目标表单列“G”设置为格式化“dd / mm / yyyy”：

Private Sub CommandButton1_Click()
Me.Hide
If Sheets("Masri").Visible Then
  Sheet10.Activate
  Sheet10.Cells.Clear
  Sheet10.Cells.ClearFormats
   Range("A1:I2").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark2
        .TintAndShade = -0.499984740745262
        .PatternTintAndShade = 0
    End With
    With Selection.Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
    Selection.Font.Bold = True
    Range("A1:I2").Select
    ActiveCell.FormulaR1C1 = _
        "Number of Days between ANSI's Aproved But not Catalogued"
    Range("A3:I3").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark2
        .TintAndShade = -0.249977111117893
        .PatternTintAndShade = 0
    End With
    Range("A3:I3").Select
    ActiveCell.FormulaR1C1 = "MASRI"
    Range("A4").Select
    ActiveCell.FormulaR1C1 = "Progress"
    Selection.Font.Bold = True
    Range("B4").Select
    ActiveCell.FormulaR1C1 = "ANSI#"
    Selection.Font.Bold = True
     Range("C4").Select
    ActiveCell.FormulaR1C1 = "Area"
    Selection.Font.Bold = True
     Range("D4").Select
    ActiveCell.FormulaR1C1 = "Supplier"
    Selection.Font.Bold = True
     Range("E4").Select
    ActiveCell.FormulaR1C1 = "Description"
    Selection.Font.Bold = True
     Range("F4").Select
    ActiveCell.FormulaR1C1 = "Approved Date"
    Selection.Font.Bold = True
     Range("G4").Select
    ActiveCell.FormulaR1C1 = "Catalogued Date"
    Selection.Font.Bold = True
     Range("H4").Select
    ActiveCell.FormulaR1C1 = "Approved By"
    Selection.Font.Bold = True
     Range("I4").Select
    ActiveCell.FormulaR1C1 = "Days Overdue"
    Selection.Font.Bold = True
    Range("A4:I4").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("A4:I4").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorLight2
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
    End With
    Range("A1:I4").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("G5:G40").NumberFormat = "dd/mm/yyyy"
    Columns("A:A").ColumnWidth = 18.43
    Columns("B:B").ColumnWidth = 12
    Columns("C:C").ColumnWidth = 4.43
    Columns("D:D").ColumnWidth = 34.86
    Columns("E:E").ColumnWidth = 60.71
    Columns("F:F").ColumnWidth = 15.14
    Columns("G:G").ColumnWidth = 15.14
    Columns("H:H").ColumnWidth = 20.57
    Columns("I:I").ColumnWidth = 37.86
    ActiveSheet.Shapes.Range(Array("Rounded Rectangle 1")).Select
    Range("A1:I2").Select
    ActiveSheet.Shapes.Range(Array("Rounded Rectangle 1")).Select
    Selection.ShapeRange.IncrementLeft -2.25
    Selection.ShapeRange.IncrementTop 0.75
    Selection.ShapeRange.IncrementLeft 2.25
    Selection.ShapeRange.IncrementTop -0.75
    Sheets("Masri").Select
    Dim FinalRow As Long, lastTargetRow As Long, lastCol As Long, tRow As Long
    Dim source As String, target As String
    Dim ThisValue As Date
     source = "Masri"        'Define your source sheet
     target = "Reports"      'Define Target sheet
     FinalRow = Sheets(source).Range("G" & Rows.Count).End(xlUp).Row
     lastCol = Sheets(source).Cells(1, Columns.Count).End(xlToLeft).Column   'If header in Row 1
     lastTargetRow = Sheets(target).Range("G" & Rows.Count).End(xlUp).Row
     tRow = lastTargetRow + 1
    For lRow = 2 To FinalRow
     ThisValue = Sheets(source).Cells(lRow, 7).Value
        If ThisValue = tempDate Then
         For lCol = 1 To lastCol  'Copy entire row
                Sheets(target).Cells(tRow, lCol).Value = Sheets(source).Cells(lRow, lCol).Value
            Next lCol
            tRow = tRow + 1         'THIS IS THE KEY TO NOT JUST COPYING THE LAST RECORD
        End If
    Next lRow
    End If
End Sub

1 个答案:

答案 0 :(得分：1)

看起来您的问题是您将最后一条记录复制到上一条记录之上。如果您单步执行代码，则可以确认该理论。

当然，你可能有更多的代码高于你的问题所包含的代码，从“End Sub”之前的延迟“End If”来判断。为了宣布变量，我只是将它视为独立，所以你知道它们是什么类型。

查看此代码，通过设置值来简化操作，而不是复制和粘贴。

它使用For循环遍历源表，就像代码一样 然后执行条件测试。如果找到匹配项，则完成从源表上的值设置目标工作表上的值的所有列的嵌套循环。

注意：最后一行正在按“C”，（3）列进行检查，因为您的代码显示了该行。 

Sub ConditionalCopy()

Dim FinalRow As Long, lastTargetRow As Long, lastCol As Long, tRow As Long
Dim source As String, target As String
Dim ThisValue As Date

source = "Masri"        'Define your source sheet
target = "Reports"      'Define Target sheet

FinalRow = Sheets(source).Range("C" & Rows.count).End(xlUp).row
lastCol = Sheets(source).Cells(1, Columns.count).End(xlToLeft).column   'If header in Row 1

lastTargetRow = Sheets(target).Range("C" & Rows.count).End(xlUp).row
tRow = lastTargetRow + 1

    For lRow = 2 To FinalRow

        ThisValue = Sheets(source).Cells(lRow, 7).Value

        If ThisValue = Date() Then
            For lCol = 1 To lastCol  'Copy entire row
                Sheets(target).Cells(tRow, lCol).Value = Sheets(source).Cells(lRow, lCol).Value
            Next lCol
            tRow = tRow + 1         'THIS IS THE KEY TO NOT JUST COPYING THE LAST RECORD
        End If
    Next lRow
End Sub

更新：看到剩下的代码后，我强烈建议减少任何选择语句。

以下是一个例子：

Range("F4").Select
ActiveCell.FormulaR1C1 = "Approved Date"

这不是必需的，而且是额外的工作，因为您无需选择范围来设置其公式或任何其他属性。他们在那里的原因可能是因为记录了一个宏，这是一个很好的起点。它模拟你使用工作表，而不是仅仅使用一个小工作表执行所需的操作，你可能没有注意到差异，除了屏幕全部轻弹，但在一个大的工作表中，它肯定会导致问题。这也不是一个好习惯。

考虑一下：

Range("F4").FormulaR1C1 = "Approved Date"

另一个例子：

Range("A1:I2").Select
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlBottom
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
End With

将修改为：

With Range("A1:I2")
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlBottom
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
End With

此链接How to avoid using Select in Excel Macros提供了更多示例。您可以访问任何属性，如Selection.Interior，只需使用实际选择NAME而不是“选择”。要合并范围，您只需说

Range("A1:I2").Merge
'or
Range("A1:I2").Unmerge
相关问题
最新问题