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

Question

yuko0909

8

8もっと見る

650pt

コンピュータウェブ制作

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

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

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

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

回答の条件

1人10回まで

登録：2009/01/27 15:15:37
終了：2009/01/27 21:21:00

※ 有料アンケート・ポイント付き質問機能は2023年2月28日に終了しました。

No.1

SALINGER34549692009/01/27 16:57:00

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

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

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

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

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

2009/01/27 17:30:02

No.2

SALINGER34549692009/01/27 18:55:07

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のようにファイル名だけでしょうか?

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

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

2009/01/27 19:14:51

yuko0909 2009/01/27 17:27:17

すみません。。。
詳細についてコメント書くのを忘れてました･･･

仕様詳細
SHEET1について（ファイル名：sample.xls）
　・ｃ列とD列はペアです。（ｃ列に値があればｄ列にも必ず値があるし、ｄ列に値があればｃ列にも必ず値がある）
　・同様に、G列とH列もペアです。
　・I列とｊ列もペアです。
　・K列とL列もペアです。
　・M列とN列もペアです。
　・D列、E列、F列、H列、J列、L列、N列、O列、P列、Q列、R列の値はURL形式です。

編集
　・URLが以下の場合はX列～AQ列の”（URL）”と書いてある列にURLの最後の「/」以下の文字をどんどん入れていきます。
　　（空白の場合は無視してつめる）
　　　・URLに”true”という文字を含んでいる
　　　・URLに”sample”という文字を含んでいる
　　例）URLの最後の「/」以下の文字とは？
　　　⇒http://www.xxxx.co.jp/sssss/aaa.htmlというURLだったとすると、「aaa.html」の部分

　・URLが上記の場合以外はD列～V列の”（URL）”と書いてある列にURLをどんどん入れていきます。
　　（空白の場合は無視してつめる）

　・D列に値がある場合はその値を出力するセルの一つ前のセルにC列の値を出力する
　・E列に値がある場合はその値を出力するセルの一つ前のセルに”地図１”と出力する
　・F列に値がある場合はその値を出力するセルの一つ前のセルに”地図２”と出力する
　・H列に値がある場合はその値を出力するセルの一つ前のセルにG列の値を出力する
　・J列に値がある場合はその値を出力するセルの一つ前のセルにI列の値を出力する
　・L列に値がある場合はその値を出力するセルの一つ前のセルにK列の値を出力する
　・N列に値がある場合はその値を出力するセルの一つ前のセルにM列の値を出力する
　・O列に値がある場合はその値を出力するセルの一つ前のセルに”案内１”と出力する
　・P列に値がある場合はその値を出力するセルの一つ前のセルに”案内２”と出力する
　・Q列に値がある場合はその値を出力するセルの一つ前のセルに”案内３”と出力する
　・FR列に値がある場合はその値を出力するセルの一つ前のセルに”案内４”と出力する

　・X～AQ列への出力がおわったら、続きのセル（URLと書いてある列）に下記のファイル名を出力する。
　　　sample.xlsと同じ階層にdateという名前のフォルダが存在し、そのフォルダの中にはID番号を名前とするフォルダが存在している。
　　　（ID番号のフォルダがない場合もある）
　　　そのフォルダの中にあるファイル名をとってきて、ID番号が一致する行のX列～AQ列のURL部分に出力していく。
　　　ファイル名を出力したセルのひとつ前のセルにsample.xlsのB列の値を出力する
SALINGER 2009/01/27 18:33:19

・URLに”true”という文字を含んでいる
・URLに”sample”という文字を含んでいる
というのは、どちらかを満たしている（or)でいいでしょうか？

上記の条件を満たさないときは、URLは全てでしょうか?
aaa.htmlのようにファイル名だけでしょうか?

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

リクエスト送信済

回答リクエストを送信したユーザーはいません

SALINGER · Accepted Answer · 2009-01-27T19:30:04+09:00

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

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

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

SALINGER · Accepted Answer · 2009-01-27T19:30:04+09:00

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

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

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

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

ベストアンサー

SALINGER34549692009/01/27 19:30:04

その他の回答（2件）

SALINGER34549692009/01/27 16:57:00

SALINGER34549692009/01/27 18:55:07

SALINGER34549692009/01/27 19:30:04ここでベストアンサー

コメント（2件)

この質問への反応（ブックマークコメント）