エクセルVBAについて

質問

エクセルVBA初心者です。
以下のような処理をしたくて、色々な質問等を見て組み合わせて動かしてみたものの、なかなかうまくいかず困っております。アドバイスいただけないでしょうか？

「Sheet1」に以下のようなデータがあります。

<A列>　<B列> <C列>
ok59　 886 ok88
ok70 777 ok75
okGG 478 ok66
ok97 358 ok58
ok69 764 ok47
ok39 368 ok40
okGG 794 ok68
ok85 463 ok75
・　　　　・ ・
・　　　　・ ・

A列とC列にはそれぞれ「ok＋2桁の数字or文字」が入っています。
B列は特に今回は使わないデータですが、数字が入っています。

やりたいことは以下の通りです。

A列に「GG」を含む文字列（実質okGGしかない状態です）が出てきたとき、
その１つ下の行のA列とC列のセルをピックアップし、背景色をピンク色にします。
上の例だと、A列は「ok97」と「ok85」、B列は「ok58」と「ok75」のセルが該当します。

さらにピンク色にピックアップしたセルのから、頭の「ok」を除いた数字を3.5倍した数字を、
別のシートに抽出したいのです。

なので、上の例を使用した場合の抽出したデータは以下のようになります。

<A列> <B列>
339.5 203
297.5 262.5

ちょっと複雑なのですが、どのようにするのがよいのでしょうか？

また、別シートに抽出したいのですが、
「Sheet1」の特定のセルに日付が入っているので、
できればその日付の名前のシートを作り、そこに抽出できたらなぁ・・・と考えています。
「Sheet1」にデータを貼り付けて、ボタンをポンっとおしたら日付の名前のシートができて、
欲しいデータが抽出されていく・・・というイメージです考えています。

どうぞよろしくお願いします。

回答No.4

mu2011

一例です。
Sheet1のシートタブ上で右クリック→コードの表示→sampleコード貼り付け→シート上でAlt＋F8キー押下、sample実行
因みに日付シート名は「yyyymmdd」、日付はSheet1のD1としています。（既に同日付のシートがある場合は実行前に削除して下さい）

Sub sample()
Dim i As Long, j As Long
With Worksheets.Add(after:=Worksheets(Worksheets.Count))
.Name = Format(Range("D1"), "yyyymmdd")
.Cells.ClearContents
For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
If Cells(i, "A") Like "*GG*" Then
j = j + 1
.Cells(j, "A") = Val(Replace(Cells(i + 1, "A"), "ok", "")) * 3.5
.Cells(j, "B") = Val(Replace(Cells(i + 1, "C"), "ok", "")) * 3.5
Cells(i + 1, "A").Interior.ColorIndex = 38
Cells(i + 1, "C").Interior.ColorIndex = 38
End If
Next
End With
End Sub

回答No.3

kagakusuki

申し訳御座いません、御質問文中の

>頭の「ok」を除いた数字を3.5倍した数字を、別のシートに抽出したいのです。

という一文を見落としておりました。
　ですから、回答No.2のVBAのままでは、御希望に沿う事は出来ませんので、以下の様なVBAとして下さい。

Sub Macro00()

Sheets("Sheet1").Select
If Not IsDate(Range("E1")) Then Exit Sub
Dim d As String
d = Format(Range("E1"), "yyyy-m-d")
Dim dws As Worksheet
On Error Resume Next
If Sheets(d) Is Nothing Then
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = d
Set dws = Sheets(Sheets.Count)
Else
Sheets(d).Copy After:=Sheets(Sheets.Count)
Set dws = Sheets(Sheets.Count)
d = dws.Name
End If
On Error GoTo 0
Sheets("Sheet1").Select
If WorksheetFunction.CountIf(Columns("A:A"), "*?") = 0 Then Exit Sub
Dim lr As Long
lr = WorksheetFunction.Match("*?", Columns("A:A"), -1)
Application.CutCopyMode = False
Columns("C:C").Cut
Columns("B:B").Insert Shift:=xlToRight
Columns("A:A").Insert Shift:=xlToRight
Range("B2:B" & lr).Offset(1, -1).Value = Range("B2:B" & lr).Value
Application.CutCopyMode = False
Range("A1:C" & lr).AutoFilter Field:=1, Criteria1:="*GG*"
Range("B1:C" & lr).Copy
dws.Select
With Range("A1")
ActiveSheet.Paste
.PasteSpecial Paste:=xlPasteValues
End With
Sheets("Sheet1").Select
Range("B2:C" & lr).Interior.Color = 8421631
Application.CutCopyMode = False
Selection.AutoFilter
Columns("C:C").Cut
Columns("E:E").Insert Shift:=xlToRight
Columns("A:A").Delete Shift:=xlToLeft
dws.Select
Columns("A:B").Replace What:="ok", Replacement:=""
Application.CutCopyMode = False
Columns("A:B").Insert Shift:=xlToRight
Range("A2:B" & lr).FormulaR1C1 = _
"=IF(AND(ISNUMBER(SUBSTITUTE(RC[2],""ok"",)+0),SUBSTITUTE(RC[2],""ok"",)<>""""),SUBSTITUTE(RC[2],""ok"",)*3.5,RC[2]&"""")"
Range("C2:D" & lr).Value = Range("A2:B" & lr).Value
Columns("A:B").Delete Shift:=xlToLeft
End Sub

回答No.2

kagakusuki

以下の様なVBAでは如何でしょうか。

Sub Macro01()

Sheets("Sheet1").Select
If Not IsDate(Range("E1")) Then Exit Sub
Dim d As String
d = Format(Range("E1"), "yyyy-m-d")
Dim dws As Worksheet
On Error Resume Next
If Sheets(d) Is Nothing Then
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = d
Set dws = Sheets(Sheets.Count)
Else
Sheets(d).Copy After:=Sheets(Sheets.Count)
Set dws = Sheets(Sheets.Count)
d = dws.Name
End If
On Error GoTo 0
Sheets("Sheet1").Select
If WorksheetFunction.CountIf(Columns("A:A"), "*?") * WorksheetFunction.CountIf(Columns("C:C"), "*?") = 0 Then Exit Sub
Dim lr As Long
lr = WorksheetFunction.Max(WorksheetFunction.Match("*?", Columns("C:C"), -1), WorksheetFunction.Match("*?", Columns("C:C"), -1))
Columns("C:C").Cut
Columns("B:B").Insert Shift:=xlToRight
Columns("A:A").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").Value = " "
Range("A2:A" & lr).FormulaR1C1 = _
"=IF(ISNUMBER(FIND(""GG"",R[-1]C2)),""〇"","""")"
Columns("B:D").Copy
dws.Columns("A:A").Insert Shift:=xlToRight
dws.Columns("A:C").Clear
Sheets("Sheet1").Select
Columns("A:D").Select
Application.CutCopyMode = False
Columns("A:D").AutoFilter Field:=1, Criteria1:="〇"
Range("B1:D" & lr).Select
Selection.Copy
dws.Select
Range("A1").Select
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Columns("C:C").Cut
Columns("B:B").Insert Shift:=xlToRight
'Sheets("Sheet1").Select

With Sheets("Sheet1")
.Range("B2:C" & lr).Interior.Color = 8421631
.Columns("A:D").AutoFilter
.Columns("C:C").Cut
.Columns("E:E").Insert Shift:=xlToRight
.Columns("A:A").Delete Shift:=xlToLeft
End With
dws.Range("A1").Select

End Sub

回答No.1

OrangeCup150

こんな感じにしてください。（ Excel 2007 で動作確認 )
Range.Find の SearchDirection は Excel 2007 で追加されたとあるので古いバージョンを使用している場合削除してください。

Public Sub GG_CHECK()
Application.ScreenUpdating = False

' 検索範囲は A1:A1000
With Worksheets("Sheet1").Range("A1:A1000")
' 検索開始位置は A1
Set 検索結果 = .Find("GG", After:=Worksheets("Sheet1").Range("A1"), LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, MatchByte:=True)
' 完全一致検索の場合は下の検索条件を使用する
' Set 検索結果 = .Find("okGG", After:=Worksheets("Sheet1").Range("A1"), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, MatchByte:=True)

If Not 検索結果 Is Nothing Then
firstAddress = 検索結果.Address

Dim 出力先シート As Worksheet
Set 出力先シート = Worksheets.Add

If Len(Worksheets("Sheet1").Range("F1").Value) <> 0 Then
' シート名の設定（Sheet1 の F1 の日付を参照）
' シート名に / は使用できないので . 区切りを使用
Dim シート名 As String
シート名 = Format(Worksheets("Sheet1").Range("F1").Value, "yyyy.mm.dd")
' 同名のシートが存在した場合は名前を設定しない
If Worksheets(シート名) Is Nothing Then
出力先シート.Name = シート名
End If
End If

Dim 塗る色 As Long
塗る色 = RGB(255, 128, 255)

Dim 検出数 As Long
検出数 = 0

Do
検出数 = 検出数 + 1
' 値の抽出（ ok99 から 99 を取り出して3.5倍）
出力先シート.Cells(検出数, 1) = CDbl(Mid(検索結果(2, 1).Value, Start:=3, Length:=2)) * 3.5
出力先シート.Cells(検出数, 2) = CDbl(Mid(検索結果(2, 3).Value, Start:=3, Length:=2)) * 3.5

' 書式設定
検索結果(2, 1).Interior.Color = 塗る色
検索結果(2, 3).Interior.Color = 塗る色

Set 検索結果 = .FindNext(検索結果)
Loop While Not 検索結果 Is Nothing And 検索結果.Address <> firstAddress
End If
End With

Application.ScreenUpdating = True
End Sub