Огромная просьба помочь с написанием небольшого макроса

[ds_nn]

doober
подскажи пожалуйста еще))
тело в том что в выгруженной таблице дата выглядит примерно так "2006-08-17 00:00:00.000" к нормальной форме я приводил его вот так

Sub q()
lstr = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lstr
Cells(i, 3) = Mid(Cells(i, 3), 1, 10)
Next i
End Sub

куда это сейчас можно засунуть?)) или может еще какой способ есть?
я что-то никак не могу понять...

[doober]

может еще какой способ есть?

Самый простой способ получения результата за один заход-это предоставить реальный файл-записей на 3-4.мыло и фамилии не интересуют.

[doober]

Sub Sbor()
Application.ScreenUpdating = False
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim n As Integer, L As Integer
Dim Dan_data, Dan_email
On Error Resume Next
Set sh1 = GetObject(GetFolderPath).Sheets("Лист3") ' как в примере

Dan_data = sh1.UsedRange.Value
sh1.Parent.Close (False)

Set sh2 = GetObject(GetFolderPath).Sheets("Лист3") ' как в примере
Dim rng As Range
L = 1

For n = 1 To UBound(Dan_data)

If Int(Now - CDate(Mid(Dan_data(n, 3), 1, 10))) > 365 Then

Set rng = sh2.Columns(1).Find(Dan_data(n, 1))

If Not rng Is Nothing Then
ThisWorkbook.Worksheets(1).Cells(L, 1) = Dan_data(n, 1)
ThisWorkbook.Worksheets(1).Cells(L, 2) = rng.Offset(0, 3)

L = L + 1
End If

End If

Next

sh2.Parent.Close (False)


Application.ScreenUpdating = True
End Sub

[ds_nn]

вот какая получается таблица, после выгрузки...

[doober]

Sub Sbor()
Application.ScreenUpdating = False
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim n As Integer, L As Integer
Dim Dan_data, Dan_email
On Error Resume Next
Set sh1 = GetObject(GetFolderPath).Sheets(1) 
n = sh1.Columns("I:I").SpecialCells(xlCellTypeConstants).Rows.Count
Dan_data = sh1.Range("I1:S" & n)
sh1.Parent.Close (False)

Set sh2 = GetObject(GetFolderPath).Sheets(3) 
Dim rng As Range
L = 1

For n = 1 To UBound(Dan_data)

If Int(Now - CDate(Mid(Dan_data(n, 4), 1, 10))) > 730 Or _
Int(Now - CDate(Mid(Dan_data(n, 11), Len(Dan_data(n, 11)) - 10, 10))) > 365 Then

Set rng = sh2.Columns(1).Find(Dan_data(n, 1))

If Not rng Is Nothing Then
ThisWorkbook.Worksheets(1).Cells(L, 1) = Dan_data(n, 1)
ThisWorkbook.Worksheets(1).Cells(L, 2) = rng.Offset(0, 3)

L = L + 1
End If

End If

Next

sh2.Parent.Close (False)


Application.ScreenUpdating = True
End Sub