VBAでのテキストの抽出と、特定テキストを含む範囲の別位置へのコピーをしたい。

画像に添付してあるような処理を行いたいのですが、ある行（画像ではK）全体の値すべてを一度検索し、一秒や一分、一時間単位で横のセルにコピーし続けるという処理です。画像では一秒ごとで例を示しているのですが、たとえば00:03:00から00:06:00などの、３分間隔を12:00:00や12:30:50まで処理する、などの処理を行いたいです。また、その際にK行の隣にあるセル（画像ではL）などの範囲も一緒にコピー対象にする、などという処理も追加できれば非常にありがたいです。

VBAに詳しい方のプログラムを知りたいです。よろしくお願いいたします。

No.1 回答者： tom04 回答日時： 2015/05/29 11:26

こんにちは！

＞たとえば00:03:00から00:06:00などの、３分間隔を12:00:00や12:30:50まで処理する・・・
がいまいち理解できないので、
画像通りの場合の一例です。
元データはSheet1にあるとします。
Sheet2を作業用のSheetとして使用していますので、Sheet2は全く使っていない状態にしておいてください。
標準モジュールです。


Sub Sample1()
Dim i As Long, myMax As Long
Dim lastRow As Long, lastCol As Long
Dim wS As Worksheet
Set wS = Worksheets("Sheet2")
Application.ScreenUpdating = False
With Worksheets("Sheet1")
'//作業列としてM列を挿入
.Range("M:M").Insert
.Range("M1") = "ダミー"
lastRow = .Cells(Rows.Count, "K").End(xlUp).Row
lastCol = .Cells(2, Columns.Count).End(xlToLeft).Column
If lastRow > 1 And lastCol > Range("N1").Column Then
Range(.Cells(2, "O"), .Cells(lastRow, lastCol)).ClearContents
End If
With Range(.Cells(2, "M"), .Cells(lastRow, "M"))
.Formula = "=ROUND(K2,7)*10^7" '//←浮動小数誤差調整のため
.Value = .Value
End With
.Range("M:M").AdvancedFilter Action:=xlFilterCopy, copytorange:=wS.Range("A1"), unique:=True
For i = 2 To wS.Cells(Rows.Count, "A").End(xlUp).Row
.Range("M:M").AutoFilter field:=1, Criteria1:=wS.Cells(i, "A")
Range(.Cells(2, "K"), .Cells(lastRow, "L")).SpecialCells(xlCellTypeVisible).Copy _
wS.Cells(1, Columns.Count).End(xlToLeft).Offset(, 1)
myMax = WorksheetFunction.Max(myMax, wS.Cells(Rows.Count, (i - 1) * 2).End(xlUp).Row)
Next i
.AutoFilterMode = False
.Range("M:M").Delete
lastCol = wS.Cells(1, Columns.Count).End(xlToLeft).Column
Range(wS.Cells(1, "B"), wS.Cells(myMax, lastCol)).Copy .Range("N2")
.Columns.AutoFit
wS.Cells.Clear
End With
Application.ScreenUpdating = True
End Sub

こんな感じではどうでしょうか？m(_ _)m