从与特定日期匹配的列表中提取值 - Excel VBA循环

Posted 2021-04-03

我非常感谢excel VBA的一些帮助 -

我在一张纸上有2个数据列，两者之间也有空白

  name         Date
   a        01-01-2019
   c        01-08-2019

   b        01-02-2019
   f        01-01-2019 

. . .

我试图在同一工作簿中的另一个工作表上显示按日期顺序组织的这些列，没有空格。例如：

 name      date
  a       01-01-19
  f       01-01-19
  b       01-02-19
  c       01-08-19

我已经尝试过使用For Each循环，其中包含一些If语句，但它没有达到预期的结果，我认为这将是非常啰嗦的方式 - 我是VBA的新手，我很难得到循环工作并获得正确的结果。我看过while循环但不确定这是否是正确的方法？

非常感谢你花时间陪伴！

编辑：到目前为止在代码中添加 - （我知道它不好）！

Dim r As Range
 Dim t As Range
 Dim r2 As Range
 Dim t2 As Range
 Dim rData As Range
 Set rData = Range("C4:C70") 

 Set r = Sheets("Sheet1").Range("D4") 
 Set r2 = Sheets("Sheet1").Range("C4")  
 Set t = Sheets("Sheet2").Range("D4") 
 Set t2 = Sheets("Sheet2").Range("C4")  


  For Each r2 In rData 
    If r.Value = "01/09/2018" Then
     t = r  
      t2 = r.Offset(0, -1)
    Set r = r.Offset(1, 0) 
      Set r2 = r2.Offset(1, 0) 
      Set t = t.Offset(1, 0) 
      Set t2 = t2.Offset(1, 0) 
    End If
   If r.Value <> "" & r2.Value <> "" Then
        Set r = r.Offset(1, 0) 
        Set r2 = r2.Offset(1, 0) 
       Set t = t.Offset(1, 0) 
        Set t2 = t2.Offset(1, 0) 

   End If
    If r.Value = "01/10/2018" Then
     t = r  
     t2 = r.Offset(0, -1)

    End If
  Next r2

答案

你去吧 - 比录制的宏更干净。

Sub SortDates()

Dim sht As Worksheet, sht2 As Worksheet, lastrow As Long

Set sht = ThisWorkbook.Worksheets("Sheet1")
Set sht2 = ThisWorkbook.Worksheets("Sheet2")
lastrow = sht.Cells(sht.Rows.Count, 3).End(xlUp).Row

sht2.Range("C1:D" & lastrow).Value = sht.Range("C1:D" & lastrow).Value

sht2.Sort.SortFields.Add Key:=Range("D1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
sht2.Sort.SetRange Range("C1:D" & lastrow)
sht2.Sort.Apply

End Sub