Excel VBA質問箱 IV

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

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


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

8720 / 76732

←次へ　｜　前へ→


	【73580】Re:並べ替えについて

ウッシ - 13/1/24(木) 12:10 -


	引用なし

	パスワード

こんにちは

全部書く気にはならないので足りない分は追加して下さい。

Sub test()
　　Dim i As Long
　　Dim j As Long
　　Dim r As Long
　　Dim s As Range
　　
　　Application.ScreenUpdating = False
　　With Worksheets("Sheet1")
　　　　.Rows(1).Delete
　　　　j = .Range("E" & Rows.Count).End(xlUp).Row
　　　　
　　　　For Each s In Range("Q1:Q" & j)
　　　　　　If Not IsEmpty(s.Value) Then
　　　　　　　　s.Value = Left(s.Value, Len(s.Value) - 1)
　　　　　　End If
　　　　Next
　　　　j = j / 2
　　　　
　　　　For i = 1 To j
　　　　　　r = i * 2 - 1
　　　　　　.Range("E" & r).Copy Worksheets("Sheet2").Range("B" & i)
　　　　　　
　　　　　　Worksheets("Sheet2").Range("I" & i).Value = _
　　　　　　　　Format(Left(.Range("G" & r), 4) & "/1/1", "e")
　　　　　　Worksheets("Sheet2").Range("J" & i).Value = _
　　　　　　　　Mid(.Range("G" & r), 5, 2)
　　　　　　Worksheets("Sheet2").Range("K" & i).Value = _
　　　　　　　　Right(.Range("G" & r), 2)
　　　　　　.Range("Q" & r).Copy Worksheets("Sheet2").Range("AA" & i)
　　　　　　
　　　　　　.Range("AB" & r).Copy Worksheets("Sheet2").Range("R" & i)
　　　　　　
　　　　　　Select Case Worksheets("Sheet2").Range("R" & i).Value
　　　　　　　　Case 1 To 14: Worksheets("Sheet2").Range("S" & i).Value = 1
　　　　　　　　Case 21 To 30: Worksheets("Sheet2").Range("S" & i).Value = 2
　　　　　　　　Case Else: Worksheets("Sheet2").Range("S" & i).Value = 3
　　　　　　End Select
　　　　Next
　　End With
　　Application.ScreenUpdating = True
End Sub

253 hits

▼

【73576】並べ替えについて マリモ 13/1/23(水) 15:56