情報系の授業の課題なのですが、思ったようにできず困っています。エクセル(2010)のvbaでネットで

情報系の授業の課題なのですが、思ったようにできず困っています。エクセル(2010)のvbaでネットでの拾い物を使って改変して使用しているのですが、処理が通らず困っております。

Sub Pokemon()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim hizuke As String, wnum As String
Dim rng As Range
Dim i As Long, imax As Long
Dim j As Variant, c As Long
Dim sname As String
Dim fsh As Variant
fsh = Array("lightening", "fire", "water", "leaf", "wind", "dragon")
hizuke = InputBox("ポケモンを捕まえた日付を入力して下さい")
If hizuke = "" Then Exit Sub
If IsDate(hizuke) = False Then
MsgBox "日付不正"
Exit Sub
End If
Set sh1 = Worksheets("ポケモン図鑑")
With sh1
Set rng = .Range(.Cells(4, 5), .Cells(4, .Cells(4, Columns.Count).End(xlToLeft).Column))
End With
j = Application.Match(CLng(CDate(hizuke)), rng, 0)
If IsError(j) Then
MsgBox "該当日付がありません"
Exit Sub
End If
wnum = InputBox("選択した日付が何週目になるかを入力して下さい")
If wnum = "" Then Exit Sub
If wnum < 1 Or wnum > 5 Then
MsgBox "週不正"
Exit Sub
End If
Application.ScreenUpdating = False
c = wnum * 2 + 3
For Each sh2 In Worksheets
For i = 0 To 5
If sh2.Name = fsh(i) Then
With sh2
If .Cells(5, c) <> "" Then
.Range(.Cells(5, c), .Cells(.Cells(Rows.Count, c).End(xlUp).Row, c)).ClearContents
End If
End With
Exit For
End If
Next i
Next sh2
With sh2
If .Cells(5, c) <> "" Then
.Range(.Cells(5, c), .Cells(.Cells(Rows.Count, c).End(xlUp).Row, c)).ClearContents
End If
End With
End If
Next sh2
With sh1
imax = .Cells(Rows.Count, "A").End(xlUp).Row
For i = 6 To imax
If .Range("A" & i).Value <> "" Then
sname = .Range("D" & i).Value
Select Case sname
Case "water", "leaf", "wind", "dragon"
Case Else
If (Left(sname, 3) = "Lightning" Or Left(sname, 3) = "fire") And InStr(sname, "伝説ポケモン") = 0 Then
sname = Left(sname, 3) & "aaa"
Else
sname = ""
End If
End Select
If sname <> "" Then
Set sh2 = Worksheets(sname)
sh2.Cells(sh2.Cells(Rows.Count, c).End(xlUp).Row + 1, c).Value = .Cells(i, j + 4)
End If
End If
Next i
For i = 32 To 40
Set sh2 = Nothing
Select Case i
Case 1
Set sh2 = Worksheets("lightening")
Case 2
Set sh2 = Worksheets("fire")
Case 4
Set sh2 = Worksheets("water")
Case 6
Set sh2 = Worksheets("leaf")
Case 7
Set sh2 = Worksheets("wind")
Case 9
Set sh2 = Worksheets("dogagon")
End Select
If Not sh2 Is Nothing Then
.Cells(i, j + 4).Value = sh2.Cells(sh2.Cells(Rows.Count, c + 1).End(xlUp).Row, c + 1).Value
End If
Next i
End With
Application.ScreenUpdating = True
MsgBox "ポケモン抽出コピペ終わり！"
End Sub

友人からここが原因で通らないんじゃないの？
If (Left(sname, 3) = "Lightning" Or Left(sname, 3) = "fire") And InStr(sname, "伝説ポケモン") = 0 Then
sname = Left(sname, 3) & "aaa"
Else
……と指摘を受けたのですが、どう直せばいいのかよくわかりません。
誰がわかる方いらっしゃいますでしょうか。

質問者からの補足コメント

• 

  返事ありがとうございます
  (sname,3)の3は文字数だと思うので、まずは数値を3以上にすれば、いいのでしょうか

  No.1の回答に寄せられた補足コメントです。 補足日時：2017/05/17 23:59

• 

  回答ありがとうございます。
  恥ずかしながらVBAは今週から始まったばかりで、デバッグのステップどころか、VBAの仕組みや構文がまだまだよくわかっていない状態です。
  ご指摘ありがとうございます。
  For i = 32 To 40
  Select Case iでcase 1～case 9の点に関しては直すことができました。
  しかし、データが２つしか返ってこず、課題提出が今日なのでかなり焦ってはいるのですが、
  １つしかデータが返ってこないです。画面をじ～っと見て試行錯誤しています。

  No.2の回答に寄せられた補足コメントです。 補足日時：2017/05/18 11:08

No.2 ベストアンサー 回答者： ShowMeHow 回答日時： 2017/05/18 10:21

If Left(sname, 3) = "Lig"

If Left(sname, 9) = "Lightning"
どちらでもTrueになりえます。
もちろんfireに関しても同じ配慮は必要ですし、、、
Lightning が大文字から始まっていてfireが小文字であることに問題があるかもしれませんし、、、

かぶっているものがなければ、左3文字判定でもよいと思います。

あと、、、
For i = 32 To 40
Select Case iでcase 1～case 9って、絶対にどれも引っ掛らないと思うけど、、、

何だろう、デバッグの方法で、ステップ実行とか、習っていないのかな？
自分が思う通りの動きをしているか見ながらやるとよいよ。
http://www.239-programing.com/excel-vba/basic/ba …

この回答へのお礼

回答ありがとうございます。
あれから自分でもいじってみたのですがむずかしくなかなか期待通りにデータは返ってきませんでした。
ご指摘いただいた
For i = 32 To 40
Select Case iでcase 1～case 9の行に「０」として一応数値は返ってきています(^_^;)どうやら抽出とコピペのループがうまくいっていないようなのですがここだけでも解決できたのでよかったです、ありがとうございました。

お礼日時：2017/05/19 09:14

No.1 回答者： ShowMeHow 回答日時： 2017/05/17 20:25

指摘部分しか見ていませんが、、、

いろいろなsnameで、Left(sname, 3)　が何になるのか
snameが何だったらこのif文がtrueになるのかよく考えましょう。

この回答へのお礼

アドバイスありがとうございました。

お礼日時：2017/05/19 09:15