Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

5004 / 76732

←次へ　｜　前へ→


	【77342】Re:２個ペアで並べ替えと番号をつけたい

ウッシ - 15/7/24(金) 12:28 -


	引用なし

	パスワード

こんにちは

偶数個じゃない場合の最後の1個もセットするとして、

Sub test()
　　Dim i　 As Long
　　Dim j　 As Long
　　Dim k　 As Long
　　Dim n　 As Long
　　Dim sh1 As Worksheet
　　Dim sh2 As Worksheet
　　Dim t　 As Range
　　
　　n = Range("OT1").Column
　　
　　Set sh1 = Worksheets("Sheet1")
　　Set sh2 = Worksheets("Sheet2")
　　
　　With sh2
　　　　.Cells.Delete
　　　　.Range("A1:C1").Value = Array("番号", "経度", "緯度")
　　　　k = 1
　　　　For i = 2 To sh1.Range("A1").CurrentRegion.Rows.Count
　　　　　　Set t = sh1.Range(sh1.Cells(i, 1), sh1.Cells(i, n + 1))
　　　　　　For j = 1 To n
　　　　　　　　If t(1, j) <> "" Then
　　　　　　　　　　.Range("A" & .Rows.Count).End(xlUp).Offset(1) = k
　　　　　　　　　　.Range("A" & .Rows.Count).End(xlUp).Offset(, 1) = t(1, j)
　　　　　　　　　　Do
　　　　　　　　　　　　If j > n Then Exit Do
　　　　　　　　　　　　j = j + 1
　　　　　　　　　　Loop While t(1, j) = ""
　　　　　　　　　　.Range("A" & .Rows.Count).End(xlUp).Offset(, 2) = t(1, j)
　　　　　　　　End If
　　　　　　Next
　　　　　　k = k + 1
　　　　Next
　　End With
End Sub

340 hits

▼

【77341】２個ペアで並べ替えと番号をつけたい マリモ 15/7/24(金) 10:51