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

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


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

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

▽最新の回答へ

1 ● SALINGER
●0ポイント

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

フォルダ名となる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番号はL列でしょうか?後半ではM列となってるようです。

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


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

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

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

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


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


2 ● SALINGER
●500ポイント ベストアンサー

これでいいでしょうか。

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
◎質問者からの返答

>SALINGERさん

ありがとうございます。

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

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

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

関連質問


●質問をもっと探す●



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