エクセルマクロについて質問です。

いちばん初めにそのまま使えるようなマクロを作成してくれた方には500ポイント差し上げます。
よろしくお願いします。


長くなりますので編集方法、実行結果についてはコメント書きます。

回答の条件
  • 1人10回まで
  • 登録:2009/01/26 14:04:36
  • 終了:2009/01/26 23:08:45

ベストアンサー

id:SALINGER No.2

SALINGER回答回数3454ベストアンサー獲得回数9692009/01/26 19:23:03

ポイント500pt

これでいいでしょうか。

Option Explicit

Sub Macro1()
    Dim lastRow As Long
    Dim i As Long
    Dim j As Integer
    Dim s As String
    Dim c As Integer
    Dim buf As String
    
    lastRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    
    With Sheet2
        For i = 1 To lastRow
            c = 1
            For j = 1 To 12
                s = Sheet1.Cells(i, j).Value
                If s <> "" Then
                    If j = 10 And Sheet1.Cells(i, 11).Value <> "" Then
                        .Cells(i, c).Value = Sheet1.Cells(i, j).Value
                        c = c + 1
                    Else
                        If Left(s, 1) = "/" Or InStr(1, s, "true") > 0 Then
                            .Cells(i, c).Value = Sheet1.Cells(i, j).Value
                            c = c + 1
                        End If
                    End If
                End If
            Next j
            c = 11
            For j = 1 To 11
                s = Sheet1.Cells(i, j).Value
                If s <> "" Then
                    If j <> 10 Then
                        If Not (Left(s, 1) = "/" Or InStr(1, s, "true") > 0) Then
                            .Cells(i, c).Value = Sheet1.Cells(i, j).Value
                            c = c + 1
                        End If
                    End If
                End If
            Next j
            buf = Dir(ThisWorkbook.Path & "\ダウンロードフォルダ\" & _
                Sheet1.Range("M" & i).Value & "\*.*")
            While buf <> ""
                .Cells(i, c).Value = buf
                buf = Dir()
                c = c + 1
            Wend
        Next i
    End With
    
    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\links_csv.csv", _
        FileFormat:=xlCSV, CreateBackup:=False

End Sub
id:yuko0909

>SALINGERさん

ありがとうございます。

サンプルデータとして利用しているlinks.xlsは4行目までありますが、上のマクロを実行したところ、2行目までしか結果が表示されません…。

なにか理由はわかりますでしょうか?

質問ばかりで申し訳ありません。

2009/01/26 20:47:01

その他の回答(1件)

id:SALINGER No.1

SALINGER回答回数3454ベストアンサー獲得回数9692009/01/26 18:48:24

仕様についていくつか質問があります。

フォルダ名となるID番号はL列でしょうか?後半ではM列となってるようです。

K列の値は必ずURL1形式ということは、J列の表示位置の判別はK列が空白かどうかでいいのでしょうか。

後の方のURL1形式のときというのはURL2形式のときの間違いでしょうか。


とりあえずL列がID番号とした場合。

Option Explicit

Sub Macro1()
    Dim lastRow As Long
    Dim i As Long
    Dim j As Integer
    Dim s As String
    Dim c As Integer
    Dim buf As String
    
    lastRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    
    With Sheet2
        For i = 1 To lastRow
            c = 1
            For j = 1 To 11
                s = Sheet1.Cells(i, j).Value
                If s <> "" Then
                    If j = 10 And Sheet1.Cells(i, 11).Value <> "" Then
                        .Cells(i, c).Value = Sheet1.Cells(i, j).Value
                        c = c + 1
                    Else
                        If Left(s, 1) = "/" Or InStr(1, s, "true") > 0 Then
                            .Cells(i, c).Value = Sheet1.Cells(i, j).Value
                            c = c + 1
                        End If
                    End If
                End If
            Next j
            c = 11
            For j = 1 To 11
                s = Sheet1.Cells(i, j).Value
                If s <> "" Then
                    If Not (j = 10 And Sheet1.Cells(i, 11).Value <> "") Then
                        If Not (Left(s, 1) = "/" Or InStr(1, s, "true") > 0) Then
                            .Cells(i, c).Value = Sheet1.Cells(i, j).Value
                            c = c + 1
                        End If
                    End If
                End If
            Next j
            buf = Dir(ThisWorkbook.Path & "\ダウンロードフォルダ\" & _
                Sheet1.Range("L" & i).Value & "\*.*")
            While buf <> ""
                .Cells(i, c).Value = buf
                buf = Dir()
                c = c + 1
            Wend
        Next i
    End With
    
    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\links_csv.csv", _
        FileFormat:=xlCSV, CreateBackup:=False

End Sub
id:yuko0909

すばやい回答ありがとうございます。例がずれまくっていてわかりにくくてすみません。

>フォルダ名となるID番号はL列でしょうか?後半ではM列となってるようです。

⇒すみません。。間違えました。L列ではなく、M列です。


>K列の値は必ずURL1形式ということは、J列の表示位置の判別はK列が空白かどうかでいいのでしょうか。

⇒K列に値が入っていたとしたら、その値は必ずURL1形式です。J列が表示されないのはK列が空白のときのみです。

>後の方のURL1形式のときというのはURL2形式のときの間違いでしょうか。

⇒すみません。間違いです。URL2が正しいです。


以上で修正可能でしょうか?

2009/01/26 19:11:37
id:SALINGER No.2

SALINGER回答回数3454ベストアンサー獲得回数9692009/01/26 19:23:03ここでベストアンサー

ポイント500pt

これでいいでしょうか。

Option Explicit

Sub Macro1()
    Dim lastRow As Long
    Dim i As Long
    Dim j As Integer
    Dim s As String
    Dim c As Integer
    Dim buf As String
    
    lastRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    
    With Sheet2
        For i = 1 To lastRow
            c = 1
            For j = 1 To 12
                s = Sheet1.Cells(i, j).Value
                If s <> "" Then
                    If j = 10 And Sheet1.Cells(i, 11).Value <> "" Then
                        .Cells(i, c).Value = Sheet1.Cells(i, j).Value
                        c = c + 1
                    Else
                        If Left(s, 1) = "/" Or InStr(1, s, "true") > 0 Then
                            .Cells(i, c).Value = Sheet1.Cells(i, j).Value
                            c = c + 1
                        End If
                    End If
                End If
            Next j
            c = 11
            For j = 1 To 11
                s = Sheet1.Cells(i, j).Value
                If s <> "" Then
                    If j <> 10 Then
                        If Not (Left(s, 1) = "/" Or InStr(1, s, "true") > 0) Then
                            .Cells(i, c).Value = Sheet1.Cells(i, j).Value
                            c = c + 1
                        End If
                    End If
                End If
            Next j
            buf = Dir(ThisWorkbook.Path & "\ダウンロードフォルダ\" & _
                Sheet1.Range("M" & i).Value & "\*.*")
            While buf <> ""
                .Cells(i, c).Value = buf
                buf = Dir()
                c = c + 1
            Wend
        Next i
    End With
    
    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\links_csv.csv", _
        FileFormat:=xlCSV, CreateBackup:=False

End Sub
id:yuko0909

>SALINGERさん

ありがとうございます。

サンプルデータとして利用しているlinks.xlsは4行目までありますが、上のマクロを実行したところ、2行目までしか結果が表示されません…。

なにか理由はわかりますでしょうか?

質問ばかりで申し訳ありません。

2009/01/26 20:47:01
  • id:yuko0909
    以下のようなファイルとフォルダがあります。
    ファイル名:links.xls
          このファイルのA列~I列、K列にはURLが記載されています。J列には任意の文字列、L列にはID番号が記載されています。

      A列   B列   C列   D列   E列   F列   G列   H列   I列   J列 K列   L列   M列
      URL1   URL1            URL2   URL2   URL2   URL1 あああ URL1   URL2   A0001
    URL2 URL1 URL1 URL2 URL2 URL1 URL1           URL2 A0005
          URL1 URL1 URL1 URL2 あああ URL1    A0003
    URL1 URL1 URL1            A0004

    フォルダ名:ダウンロードフォルダ
     ・このフォルダの中にはlinks.xlsのL列のID番号がフォルダ名になっているフォルダが存在します。
      (フォルダが存在しない場合もあります)
     ・各フォルダの中には、拡張子がpdf、xls、jtd、docのファイルが存在しています。
      (ファイルの最大数は5つ、ファイルが存在しない場合もある)
     <ダウンロードファイル>
       <A0001> a1.doc
       <A0005> b1.xls、b1.doc
       <A0003> c1.pdf、c1.jtd、c1.xls、c1.doc


    編集結果:links_csv.csvとして保存

     A列  B列  C列  D列  E列  F列  G列  H列  I列  J列  K列  L列  M列  N列  O列  P列  Q列  R列
    A’  B’  H’ あああ  K’                    E’ F’  G’  L’  a1.doc
    C’  D’  G’  I’                       A’  E’  F’  L’  b1.xls b1.doc
     B’  C’  E’ あああ K’                    F’ c1.pdf c1.jtd c1.xls c1.doc
     D’  F’  I’

    説明
     ・もとファイルのA列~J列に文字列がはっています。
     ・URL1、URL2とありますが、これはセルの中にある値ではなく、セルの中に入っている値の形式をあらわしていると考えてください。
      実際にセルの中に入っている値はURLです。
       URL1形式とは・・・URLの中に”true”という文字列が含まれている。またはURLが”/”から始まっている。
       URL2形式とは・・・URL1形式以外のとき
     ・編集結果で「’」をつけてあらわしているのは各セルの値のことです。アルファベットはどの列の値かを示しています。
      たとえば、links.xlsの一行目目のA列に「http://aaaaaaaa.cccc/ccc.html」と入っていたとしたら、links_csv.csvの一行目目のA列に出力されているのも「http://aaaaaaaa.cccc/ccc.html」です。つまり、links.xlsのA列の値=A’です。
    編集
     ・links.xlsの各セルに入っているURLがURL1形式のとき
       A列~J列に値を出力します。
       links.xlsで空欄になっているセルは無視して、セルに値が入っているものからどんどんつめて出力していきます。
       links.xlsのK列ににURL1形式の値が入っているとき、K列の値を出力する前のセルにlinks.xlsのJ列の値を出力します。
       ※links.xlsのB列、C列、D列、H列、I列、K列の値は必ずURL1形式です。URL2形式になることはありません。
     ・links.xlsの各セルに入っているURLがURL1形式のとき
       K列~R列に値を出力します。
       links.xlsで空欄になっているセルは無視して、セルに値が入っているものからどんどんつめて出力していきます。
       links.xlsのK列ににURL1形式の値が入っているとき、K列の値を出力する前のセルにlinks.xlsのJ列の値を出力します。
       URL2形式のものの値をすべて出力し終わったら、links.xlsのM列のID番号のフォルダに入っているファイル名を出力していきます。(出力先のセルはURL2形式のものを出力し終わった続きのセル以降のセルに続けて出力)
  • id:SALINGER
    たいへん失礼しました。
    最終行を取得するところでA列で取得してるんですが、A3より下は空白となってたようです。
    8行目
    >>
    lastRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    <<

    >>
    lastRow = Sheet1.UsedRange.Rows(Sheet1.UsedRange.Rows.Count).Row
    <<
    にしてください。
  • id:yuko0909
    できました!!
    いつもありがとうございます。

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

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

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

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