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


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

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

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

回答の条件
  • 1人10回まで
  • 登録:2009/01/27 15:15:37
  • 終了:2009/01/27 21:21:00

ベストアンサー

id:SALINGER No.3

SALINGER回答回数3454ベストアンサー獲得回数9692009/01/27 19:30:04

ポイント650pt

前の回答では、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
id:yuko0909

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

2009/01/27 21:19:53

その他の回答(2件)

id:SALINGER No.1

SALINGER回答回数3454ベストアンサー獲得回数9692009/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
id:yuko0909

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

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

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

2009/01/27 17:30:02
id:SALINGER No.2

SALINGER回答回数3454ベストアンサー獲得回数9692009/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
id:yuko0909

ありがとうございます。

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

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

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

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

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

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

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

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


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

2009/01/27 19:14:51
id:SALINGER No.3

SALINGER回答回数3454ベストアンサー獲得回数9692009/01/27 19:30:04ここでベストアンサー

ポイント650pt

前の回答では、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
id:yuko0909

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

2009/01/27 21:19:53
  • id:yuko0909
    すみません。。。
    詳細についてコメント書くのを忘れてました・・・

    仕様詳細
    SHEET1について(ファイル名:sample.xls)
     ・c列とD列はペアです。(c列に値があればd列にも必ず値があるし、d列に値があればc列にも必ず値がある)
     ・同様に、G列とH列もペアです。
     ・I列とj列もペアです。
     ・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列に値がある場合はその値を出力するセルの一つ前のセルに”地図1”と出力する
     ・F列に値がある場合はその値を出力するセルの一つ前のセルに”地図2”と出力する
     ・H列に値がある場合はその値を出力するセルの一つ前のセルにG列の値を出力する
     ・J列に値がある場合はその値を出力するセルの一つ前のセルにI列の値を出力する
     ・L列に値がある場合はその値を出力するセルの一つ前のセルにK列の値を出力する
     ・N列に値がある場合はその値を出力するセルの一つ前のセルにM列の値を出力する
     ・O列に値がある場合はその値を出力するセルの一つ前のセルに”案内1”と出力する
     ・P列に値がある場合はその値を出力するセルの一つ前のセルに”案内2”と出力する
     ・Q列に値がある場合はその値を出力するセルの一つ前のセルに”案内3”と出力する
     ・FR列に値がある場合はその値を出力するセルの一つ前のセルに”案内4”と出力する

     ・X~AQ列への出力がおわったら、続きのセル(URLと書いてある列)に下記のファイル名を出力する。
       sample.xlsと同じ階層にdateという名前のフォルダが存在し、そのフォルダの中にはID番号を名前とするフォルダが存在している。
       (ID番号のフォルダがない場合もある)
       そのフォルダの中にあるファイル名をとってきて、ID番号が一致する行のX列~AQ列のURL部分に出力していく。
       ファイル名を出力したセルのひとつ前のセルにsample.xlsのB列の値を出力する
  • id:SALINGER
    ・URLに”true”という文字を含んでいる
    ・URLに”sample”という文字を含んでいる
    というのは、どちらかを満たしている(or)でいいでしょうか?

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

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

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

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

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません