人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

いつも質問ばかりなのですが、回答のできる方、ご協力お願いします。

エクセルのマクロを組んでいただきたいのですが・・・。一番に実行可能なマクロを組んでくださった方には500ポイント差し上げます。
前回、同じような仕様でとてもよいマクロを組んでいただいたのですが、仕様が変わってしまい、自分で治そうと思ったのですが無理そうなのでお願いします。

マクロ実行前、実行後のエクセルシートの状態は画像にて示しています。

詳細についてはコメントに記載します。

1233036936
●拡大する

●質問者: yuko0909
●カテゴリ:コンピュータ ウェブ制作
✍キーワード:エクセル コメント ポイント マクロ 仕様
○ 状態 :終了
└ 回答数 : 3/3件

▽最新の回答へ

1 ● SALINGER
●0ポイント

かなり前回とは違うコードとなりました。

URLの判別は前回と同じようにしています。

サンプルを見ると表示とURLは常に両方入っているようなので、前回よりも簡単にしました。

前回同様にダウンロードフォルダの中身を表示するようにしています。

無駄に長くなりましたが、同じ事を繰り返してる部分が関数に分ければかなり短くはなります。

Option Explicit

Sub Macro1()
 Dim lastRow As Long
 Dim i As Long
 Dim c As Integer
 Dim c1 As Integer
 Dim c2 As Integer
 Dim s As String
 Dim buf As String
 
 lastRow = Sheet1.UsedRange.Rows(Sheet1.UsedRange.Rows.Count).Row
 
 With Sheet2
 .Cells(1, 1).Value = "ID番号"
 .Cells(1, 2).Value = "地名"
 For i = 3 To 43 Step 2
 .Cells(1, i).Value = "(表示)"
 .Cells(1, i + 1).Value = "(URL)"
 Next i
 
 For i = 2 To lastRow
 .Cells(i, 1).Value = Sheet1.Cells(i, 1).Value
 .Cells(i, 2).Value = Sheet1.Cells(i, 2).Value
 c1 = 3
 c2 = 23
 
 s = Sheet1.Cells(i, 4).Value
 If s <> "" Then
 If InStr(1, s, "true") > 0 Or Left(s, 1) = "/" Then
 c = c1
 c1 = c1 + 2
 Else
 c = c2
 c2 = c2 + 2
 End If
 .Cells(i, c).Value = Sheet1.Cells(i, 3).Value
 .Cells(i, c + 1).Value = s
 End If
 
 s = Sheet1.Cells(i, 5).Value
 If s <> "" Then
 If InStr(1, s, "true") > 0 Or Left(s, 1) = "/" Then
 c = c1
 c1 = c1 + 2
 Else
 c = c2
 c2 = c2 + 2
 End If
 .Cells(i, c).Value = "地図1"
 .Cells(i, c + 1).Value = s
 End If
 
 s = Sheet1.Cells(i, 6).Value
 If s <> "" Then
 If InStr(1, s, "true") > 0 Or Left(s, 1) = "/" Then
 c = c1
 c1 = c1 + 2
 Else
 c = c2
 c2 = c2 + 2
 End If
 .Cells(i, c).Value = "地図2"
 .Cells(i, c + 1).Value = s
 End If
 
 s = Sheet1.Cells(i, 8).Value
 If s <> "" Then
 If InStr(1, s, "true") > 0 Or Left(s, 1) = "/" Then
 c = c1
 c1 = c1 + 2
 Else
 c = c2
 c2 = c2 + 2
 End If
 .Cells(i, c).Value = Sheet1.Cells(i, 7).Value
 .Cells(i, c + 1).Value = s
 End If
 
 s = Sheet1.Cells(i, 10).Value
 If s <> "" Then
 If InStr(1, s, "true") > 0 Or Left(s, 1) = "/" Then
 c = c1
 c1 = c1 + 2
 Else
 c = c2
 c2 = c2 + 2
 End If
 .Cells(i, c).Value = Sheet1.Cells(i, 9).Value
 .Cells(i, c + 1).Value = s
 End If
 
 s = Sheet1.Cells(i, 12).Value
 If s <> "" Then
 If InStr(1, s, "true") > 0 Or Left(s, 1) = "/" Then
 c = c1
 c1 = c1 + 2
 Else
 c = c2
 c2 = c2 + 2
 End If
 .Cells(i, c).Value = Sheet1.Cells(i, 11).Value
 .Cells(i, c + 1).Value = s
 End If
 
 s = Sheet1.Cells(i, 14).Value
 If s <> "" Then
 If InStr(1, s, "true") > 0 Or Left(s, 1) = "/" Then
 c = c1
 c1 = c1 + 2
 Else
 c = c2
 c2 = c2 + 2
 End If
 .Cells(i, c).Value = Sheet1.Cells(i, 13).Value
 .Cells(i, c + 1).Value = s
 End If
 
 s = Sheet1.Cells(i, 15).Value
 If s <> "" Then
 If InStr(1, s, "true") > 0 Or Left(s, 1) = "/" Then
 c = c1
 c1 = c1 + 2
 Else
 c = c2
 c2 = c2 + 2
 End If
 .Cells(i, c).Value = "案内1"
 .Cells(i, c + 1).Value = s
 End If

 s = Sheet1.Cells(i, 16).Value
 If s <> "" Then
 If InStr(1, s, "true") > 0 Or Left(s, 1) = "/" Then
 c = c1
 c1 = c1 + 2
 Else
 c = c2
 c2 = c2 + 2
 End If
 .Cells(i, c).Value = "案内2"
 .Cells(i, c + 1).Value = s
 End If

 s = Sheet1.Cells(i, 17).Value
 If s <> "" Then
 If InStr(1, s, "true") > 0 Or Left(s, 1) = "/" Then
 c = c1
 c1 = c1 + 2
 Else
 c = c2
 c2 = c2 + 2
 End If
 .Cells(i, c).Value = "案内3"
 .Cells(i, c + 1).Value = s
 End If

 s = Sheet1.Cells(i, 18).Value
 If s <> "" Then
 If InStr(1, s, "true") > 0 Or Left(s, 1) = "/" Then
 c = c1
 c1 = c1 + 2
 Else
 c = c2
 c2 = c2 + 2
 End If
 .Cells(i, c).Value = "案内4"
 .Cells(i, c + 1).Value = s
 End If
 
 buf = Dir(ThisWorkbook.Path & "\ダウンロードフォルダ\" & _
 Sheet1.Range("A" & i).Value & "\*.*")
 While buf <> ""
 .Cells(i, c2).Value = Sheet1.Cells(i, 2).Value
 .Cells(i, c2 + 1).Value = buf
 buf = Dir()
 c2 = c2 + 2
 Wend

 Next i
 End With
 
 ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\links_csv.csv", _
 FileFormat:=xlCSV, CreateBackup:=False

End Sub
◎質問者からの返答

すみません。詳細についてコメントを書くのを忘れていたので仕様がわからなかったと思います・・・

仕様に沿ってマクロを組んでいただけないでしょうか?

わたしのミスですので、ポイントは上げさせていただきたいと思っています。


2 ● SALINGER
●0ポイント
Sub Macro1()
 Dim lastRow As Long
 Dim i As Long
 Dim c As Integer
 Dim c1 As Integer
 Dim c2 As Integer
 Dim s As String
 Dim buf As String
 
 lastRow = Sheet1.UsedRange.Rows(Sheet1.UsedRange.Rows.Count).Row
 
 With Sheet2
 .Cells(1, 1).Value = "ID番号"
 .Cells(1, 2).Value = "地名"
 For i = 3 To 43 Step 2
 .Cells(1, i).Value = "(表示)"
 .Cells(1, i + 1).Value = "(URL)"
 Next i
 
 For i = 2 To lastRow
 .Cells(i, 1).Value = Sheet1.Cells(i, 1).Value
 .Cells(i, 2).Value = Sheet1.Cells(i, 2).Value
 c1 = 3
 c2 = 23
 
 s = Sheet1.Cells(i, 4).Value
 If s <> "" Then
 If InStr(1, s, "true") > 0 Or InStr(1, s, "sample") Then
 c = c1
 c1 = c1 + 2
 Else
 c = c2
 c2 = c2 + 2
 End If
 .Cells(i, c).Value = Sheet1.Cells(i, 3).Value
 .Cells(i, c + 1).Value = Mid(s, InStrRev(s, "/") + 1)
 End If
 
 s = Sheet1.Cells(i, 5).Value
 If s <> "" Then
 If InStr(1, s, "true") > 0 Or InStr(1, s, "sample") Then
 c = c1
 c1 = c1 + 2
 Else
 c = c2
 c2 = c2 + 2
 End If
 .Cells(i, c).Value = "地図1"
 .Cells(i, c + 1).Value = Mid(s, InStrRev(s, "/") + 1)
 End If
 
 s = Sheet1.Cells(i, 6).Value
 If s <> "" Then
 If InStr(1, s, "true") > 0 Or InStr(1, s, "sample") Then
 c = c1
 c1 = c1 + 2
 Else
 c = c2
 c2 = c2 + 2
 End If
 .Cells(i, c).Value = "地図2"
 .Cells(i, c + 1).Value = Mid(s, InStrRev(s, "/") + 1)
 End If
 
 s = Sheet1.Cells(i, 8).Value
 If s <> "" Then
 If InStr(1, s, "true") > 0 Or InStr(1, s, "sample") Then
 c = c1
 c1 = c1 + 2
 Else
 c = c2
 c2 = c2 + 2
 End If
 .Cells(i, c).Value = Sheet1.Cells(i, 7).Value
 .Cells(i, c + 1).Value = Mid(s, InStrRev(s, "/") + 1)
 End If
 
 s = Sheet1.Cells(i, 10).Value
 If s <> "" Then
 If InStr(1, s, "true") > 0 Or InStr(1, s, "sample") Then
 c = c1
 c1 = c1 + 2
 Else
 c = c2
 c2 = c2 + 2
 End If
 .Cells(i, c).Value = Sheet1.Cells(i, 9).Value
 .Cells(i, c + 1).Value = Mid(s, InStrRev(s, "/") + 1)
 End If
 
 s = Sheet1.Cells(i, 12).Value
 If s <> "" Then
 If InStr(1, s, "true") > 0 Or InStr(1, s, "sample") Then
 c = c1
 c1 = c1 + 2
 Else
 c = c2
 c2 = c2 + 2
 End If
 .Cells(i, c).Value = Sheet1.Cells(i, 11).Value
 .Cells(i, c + 1).Value = Mid(s, InStrRev(s, "/") + 1)
 End If
 
 s = Sheet1.Cells(i, 14).Value
 If s <> "" Then
 If InStr(1, s, "true") > 0 Or InStr(1, s, "sample") Then
 c = c1
 c1 = c1 + 2
 Else
 c = c2
 c2 = c2 + 2
 End If
 .Cells(i, c).Value = Sheet1.Cells(i, 13).Value
 .Cells(i, c + 1).Value = Mid(s, InStrRev(s, "/") + 1)
 End If
 
 s = Sheet1.Cells(i, 15).Value
 If s <> "" Then
 If InStr(1, s, "true") > 0 Or InStr(1, s, "sample") Then
 c = c1
 c1 = c1 + 2
 Else
 c = c2
 c2 = c2 + 2
 End If
 .Cells(i, c).Value = "案内1"
 .Cells(i, c + 1).Value = Mid(s, InStrRev(s, "/") + 1)
 End If

 s = Sheet1.Cells(i, 16).Value
 If s <> "" Then
 If InStr(1, s, "true") > 0 Or InStr(1, s, "sample") Then
 c = c1
 c1 = c1 + 2
 Else
 c = c2
 c2 = c2 + 2
 End If
 .Cells(i, c).Value = "案内2"
 .Cells(i, c + 1).Value = Mid(s, InStrRev(s, "/") + 1)
 End If

 s = Sheet1.Cells(i, 17).Value
 If s <> "" Then
 If InStr(1, s, "true") > 0 Or InStr(1, s, "sample") Then
 c = c1
 c1 = c1 + 2
 Else
 c = c2
 c2 = c2 + 2
 End If
 .Cells(i, c).Value = "案内3"
 .Cells(i, c + 1).Value = Mid(s, InStrRev(s, "/") + 1)
 End If

 s = Sheet1.Cells(i, 18).Value
 If s <> "" Then
 If InStr(1, s, "true") > 0 Or InStr(1, s, "sample") Then
 c = c1
 c1 = c1 + 2
 Else
 c = c2
 c2 = c2 + 2
 End If
 .Cells(i, c).Value = "案内4"
 .Cells(i, c + 1).Value = Mid(s, InStrRev(s, "/") + 1)
 End If
 
 buf = Dir(ThisWorkbook.Path & "\date\" & Sheet1.Range("A" & i).Value & "\*.*")
 While buf <> ""
 .Cells(i, c2).Value = Sheet1.Cells(i, 2).Value
 .Cells(i, c2 + 1).Value = buf
 buf = Dir()
 c2 = c2 + 2
 Wend

 Next i
 End With
 
End Sub
◎質問者からの返答

ありがとうございます。

先ほどのコメントに対して回答します。

>・URLに”true”という文字を含んでいる

>・URLに”sample”という文字を含んでいる

>というのは、どちらかを満たしている(or)でいいでしょうか?

⇒どちらかを満たしていればいいです。

>上記の条件を満たさないときは、URLは全てでしょうか?

>aaa.htmlのようにファイル名だけでしょうか?

上記の2つの条件のどちらにも当てはまらない場合はURLをすべて表示します。


コメントが遅くなってすみませんでした。よろしくお願いします。


3 ● SALINGER
●650ポイント ベストアンサー

前の回答では、W列より右もフィル名だけになってたので、修正しました。

サンプル画像ではAE列がありませんでしたね。

Sub Macro1()
 Dim lastRow As Long
 Dim i As Long
 Dim c As Integer
 Dim c1 As Integer
 Dim c2 As Integer
 Dim s As String
 Dim buf As String
 
 lastRow = Sheet1.UsedRange.Rows(Sheet1.UsedRange.Rows.Count).Row
 
 With Sheet2
 .Cells(1, 1).Value = "ID番号"
 .Cells(1, 2).Value = "地名"
 For i = 3 To 43 Step 2
 .Cells(1, i).Value = "(表示)"
 .Cells(1, i + 1).Value = "(URL)"
 Next i
 
 For i = 2 To lastRow
 .Cells(i, 1).Value = Sheet1.Cells(i, 1).Value
 .Cells(i, 2).Value = Sheet1.Cells(i, 2).Value
 c1 = 3
 c2 = 23
 
 s = Sheet1.Cells(i, 4).Value
 If s <> "" Then
 If InStr(1, s, "true") > 0 Or InStr(1, s, "sample") Then
 .Cells(i, c1).Value = Sheet1.Cells(i, 3).Value
 .Cells(i, c1 + 1).Value = Mid(s, InStrRev(s, "/") + 1)
 c1 = c1 + 2
 Else
 .Cells(i, c2).Value = Sheet1.Cells(i, 3).Value
 .Cells(i, c2 + 1).Value = s
 c2 = c2 + 2
 End If
 End If
 
 s = Sheet1.Cells(i, 5).Value
 If s <> "" Then
 If InStr(1, s, "true") > 0 Or InStr(1, s, "sample") Then
 .Cells(i, c1).Value = "地図1"
 .Cells(i, c1 + 1).Value = Mid(s, InStrRev(s, "/") + 1)
 c1 = c1 + 2
 Else
 .Cells(i, c2).Value = "地図1"
 .Cells(i, c2 + 1).Value = s
 c2 = c2 + 2
 End If
 End If
 
 s = Sheet1.Cells(i, 6).Value
 If s <> "" Then
 If InStr(1, s, "true") > 0 Or InStr(1, s, "sample") Then
 .Cells(i, c1).Value = "地図2"
 .Cells(i, c1 + 1).Value = Mid(s, InStrRev(s, "/") + 1)
 c1 = c1 + 2
 Else
 .Cells(i, c2).Value = "地図2"
 .Cells(i, c2 + 1).Value = s
 c2 = c2 + 2
 End If
 End If
 
 s = Sheet1.Cells(i, 8).Value
 If s <> "" Then
 If InStr(1, s, "true") > 0 Or InStr(1, s, "sample") Then
 .Cells(i, c1).Value = Sheet1.Cells(i, 7).Value
 .Cells(i, c1 + 1).Value = Mid(s, InStrRev(s, "/") + 1)
 c1 = c1 + 2
 Else
 .Cells(i, c2).Value = Sheet1.Cells(i, 7).Value
 .Cells(i, c2 + 1).Value = s
 c2 = c2 + 2
 End If
 End If
 
 s = Sheet1.Cells(i, 10).Value
 If s <> "" Then
 If InStr(1, s, "true") > 0 Or InStr(1, s, "sample") Then
 .Cells(i, c1).Value = Sheet1.Cells(i, 9).Value
 .Cells(i, c1 + 1).Value = Mid(s, InStrRev(s, "/") + 1)
 c1 = c1 + 2
 Else
 .Cells(i, c2).Value = Sheet1.Cells(i, 9).Value
 .Cells(i, c2 + 1).Value = s
 c2 = c2 + 2
 End If
 End If
 
 s = Sheet1.Cells(i, 12).Value
 If s <> "" Then
 If InStr(1, s, "true") > 0 Or InStr(1, s, "sample") Then
 .Cells(i, c1).Value = Sheet1.Cells(i, 11).Value
 .Cells(i, c1 + 1).Value = Mid(s, InStrRev(s, "/") + 1)
 c1 = c1 + 2
 Else
 .Cells(i, c2).Value = Sheet1.Cells(i, 11).Value
 .Cells(i, c2 + 1).Value = s
 c2 = c2 + 2
 End If
 End If
 
 s = Sheet1.Cells(i, 14).Value
 If s <> "" Then
 If InStr(1, s, "true") > 0 Or InStr(1, s, "sample") Then
 .Cells(i, c1).Value = Sheet1.Cells(i, 13).Value
 .Cells(i, c1 + 1).Value = Mid(s, InStrRev(s, "/") + 1)
 c1 = c1 + 2
 Else
 .Cells(i, c2).Value = Sheet1.Cells(i, 13).Value
 .Cells(i, c2 + 1).Value = s
 c2 = c2 + 2
 End If
 End If
 
 s = Sheet1.Cells(i, 15).Value
 If s <> "" Then
 If InStr(1, s, "true") > 0 Or InStr(1, s, "sample") Then
 .Cells(i, c1).Value = "案内1"
 .Cells(i, c1 + 1).Value = Mid(s, InStrRev(s, "/") + 1)
 c1 = c1 + 2
 Else
 .Cells(i, c2).Value = "案内1"
 .Cells(i, c2 + 1).Value = s
 c2 = c2 + 2
 End If
 End If
 
 s = Sheet1.Cells(i, 16).Value
 If s <> "" Then
 If InStr(1, s, "true") > 0 Or InStr(1, s, "sample") Then
 .Cells(i, c1).Value = "案内2"
 .Cells(i, c1 + 1).Value = Mid(s, InStrRev(s, "/") + 1)
 c1 = c1 + 2
 Else
 .Cells(i, c2).Value = "案内2"
 .Cells(i, c2 + 1).Value = s
 c2 = c2 + 2
 End If
 End If
 
 s = Sheet1.Cells(i, 17).Value
 If s <> "" Then
 If InStr(1, s, "true") > 0 Or InStr(1, s, "sample") Then
 .Cells(i, c1).Value = "案内3"
 .Cells(i, c1 + 1).Value = Mid(s, InStrRev(s, "/") + 1)
 c1 = c1 + 2
 Else
 .Cells(i, c2).Value = "案内3"
 .Cells(i, c2 + 1).Value = s
 c2 = c2 + 2
 End If
 End If
 
 s = Sheet1.Cells(i, 18).Value
 If s <> "" Then
 If InStr(1, s, "true") > 0 Or InStr(1, s, "sample") Then
 .Cells(i, c1).Value = "案内4"
 .Cells(i, c1 + 1).Value = Mid(s, InStrRev(s, "/") + 1)
 c1 = c1 + 2
 Else
 .Cells(i, c2).Value = "案内4"
 .Cells(i, c2 + 1).Value = s
 c2 = c2 + 2
 End If
 End If
 
 buf = Dir(ThisWorkbook.Path & "\date\" & Sheet1.Range("A" & i).Value & "\*.*")
 While buf <> ""
 .Cells(i, c2).Value = Sheet1.Cells(i, 2).Value
 .Cells(i, c2 + 1).Value = buf
 buf = Dir()
 c2 = c2 + 2
 Wend

 Next i
 End With
 
End Sub
◎質問者からの返答

ありがとうございます。できました!!

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ