Excel VBA質問箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
2219 / 13645 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【69304】大量セル書き込みの高速化 えすたろう 11/6/23(木) 15:28 質問[未読]
【69305】Re:大量セル書き込みの高速化 neptune 11/6/23(木) 16:04 回答[未読]
【69309】Re:大量セル書き込みの高速化 えすたろう 11/6/23(木) 20:09 お礼[未読]
【69313】Re:大量セル書き込みの高速化 UO3 11/6/23(木) 22:43 発言[未読]
【69306】Re:大量セル書き込みの高速化 UO3 11/6/23(木) 16:21 回答[未読]
【69308】Re:大量セル書き込みの高速化 えすたろう 11/6/23(木) 20:08 お礼[未読]
【69310】Re:大量セル書き込みの高速化 UO3 11/6/23(木) 21:24 回答[未読]
【69311】Re:大量セル書き込みの高速化 UO3 11/6/23(木) 21:42 発言[未読]
【69334】Re:大量セル書き込みの高速化 ｍｏｍｏ 11/6/27(月) 14:34 発言[未読]
【69337】Re:大量セル書き込みの高速化 UO3 11/6/27(月) 15:45 発言[未読]
【69338】Re:大量セル書き込みの高速化 ｍｏｍｏ 11/6/27(月) 16:02 発言[未読]
【69304】大量セル書き込みの高速化
質問  えすたろう  - 11/6/23(木) 15:28 -
引用なし
パスワード
   ＶＢＡ初心者です。よろしくお願いします。

出勤時刻、退勤時刻を時間と分にわける作業を作成しています。

　　出勤時刻　退勤時刻　出勤/時間　出勤/分　退勤/時間　退勤/分
１　0930　　　1830　　　
２　0930　　　1830　　　
３　0930　　　1830　　　
・
・
・

こうした行が36000件ほどあります。

これをそれぞれ

　　出勤時刻　退勤時刻　出勤/時間　 出勤/分　退勤/時間　退勤/分
１　0930　　　1830　　　09　　　　　30　　　 18　　　　 30
２　0930　　　1830　　　09　　　　　30　　　 18　　　　 30
３　0930　　　1830　　　09　　　　　30　　　 18　　　　 30
・
・
・

といった形に分離したいと思っています。

そこで以下のようなＶＢＡを作成しました。

Private Sub 時刻変換_Click()


　　Dim shu As Variant '出勤時刻
　　Dim tai As Variant '退勤時刻
　　Dim shuhour As Variant '出勤時間
　　Dim shumini As Variant '出勤分
　　Dim taihour As Variant '退勤時間
　　Dim taimini As Variant '退勤分
　　Dim shutai As Variant '配列
　　Dim gyo As Variant

　　gyo = 2

　　Do While Worksheets("貼り付け").Cells(gyo, 1).Value <> ""
　　　　　　
　　　　　　With Worksheets("貼り付け")
　　　　　　　　shu = .Cells(gyo, 4).Offset(0, 0).Value　'出勤時刻の取り込み
　　　　　　　　tai = .Cells(gyo, 5).Offset(0, 0).Value　'退勤時刻の取り込み
　　　　　　End With

　　　　　　With Worksheets("貼り付け")
　　　　　　　　shutai = Array(Left(shu, 2), Mid(shu, 3, 2), Left(tai, 2), Mid(tai, 3, 2))　
　　　　　　End With

　　　　　　With Worksheets("貼り付け")
　　　　　　　　.Cells(gyo, 8).Offset(0, 0).Value = shutai(0)　'出勤時間の貼り付け
　　　　　　　　.Cells(gyo, 9).Offset(0, 0).Value = shutai(1)　'出勤分の貼り付け
　　　　　　　　.Cells(gyo, 10).Offset(0, 0).Value = shutai(2)　'退勤時間の貼り付け
　　　　　　　　.Cells(gyo, 11).Offset(0, 0).Value = shutai(3)　'退勤分の貼り付け
　　　　　　End With　
　　
　　gyo = gyo + 1

　　Loop
　　
　　MsgBox "完了"

End Sub


動作はきちんと動くのですが、スピードがあまりに遅いのです。

セルに順番に書き込んでるからなのだと思いますが、高速化する方法はないでしょうか？

よろしくお願いします。
【69305】Re:大量セル書き込みの高速化
回答  neptune  - 11/6/23(木) 16:04 -
引用なし
パスワード
   ▼えすたろう さん：
一番簡単だけどかなり効果のある方法
do〜loopの前後を
Application.ScreenUpdating = False
と
Application.ScreenUpdating = True
で挟む。

意味は自分で調べてね。
【69306】Re:大量セル書き込みの高速化
回答  UO3  - 11/6/23(木) 16:21 -
引用なし
パスワード
   ▼えすたろう さん：

こんにちは

アップされたコード、不要なところもありますが、たとえばそのままで
処理の最初に Application.ScreenUpdationg = False
処理の最後に Application.ScreenUpdationg = True
これをいれるだけで（2003までなら）かなり早くなると思います。

ただ、抜本的には、セルへの書き込み、これが結構ばかにならない処理コストです。
できるだけ、セルとのコンタクト回数を減らすため、
・最初にシートの内容を配列に取り込む
・配列内でループさせて処理する
・最後に一挙にシートに書き戻す。
こうすることで、処理時間は大幅に短縮されます。
この形をとるならApplication.ScreenUpdationg の手当ては不要です。

Sub Sample()
　　Dim myB As Range
　　Dim v As Variant
　　Dim i As Long
　　
　　With Sheets("貼り付け").Range("A1").CurrentRegion
　　　　Set myB = Intersect(.Cells, .Cells.Offset(1))
　　End With
　　If Not myB Is Nothing Then
　　　　v = myB.Value
　　　　For i = 1 To UBound(v, 1)
　　　　　　v(i, 3) = Left(v(i, 1), 2)
　　　　　　v(i, 4) = Mid(v(i, 1), 3)
　　　　　　v(i, 5) = Left(v(i, 2), 2)
　　　　　　v(i, 6) = Mid(v(i, 2), 3)
　　　　Next
　　　　Sheets("貼り付け").Range("A2").Resize(UBound(v, 1), UBound(v, 2)).Value = v
　　End If
　　
　　Set myB = Nothing
　　
End Sub
【69308】Re:大量セル書き込みの高速化
お礼  えすたろう  - 11/6/23(木) 20:08 -
引用なし
パスワード
   ▼UO3 さん：

こんにちは。ご提案いただいたコードでめっちゃ早くなりました。
一瞬で返還できました（驚）

ありがとうございます！

ちょっと初心者すぎて申し訳ないのですが

Sheets("貼り付け").Range("A2").Resize(UBound(v, 1), UBound(v, 2)).Value = v

というリサイズがどのような処理になっているのかだけ理解不足でして。。
【69309】Re:大量セル書き込みの高速化
お礼  えすたろう  - 11/6/23(木) 20:09 -
引用なし
パスワード
   ▼neptune さん：

ありがとうございます！

やってみましたが、やはり私のコード自体がしょぼいらしく高速にはなりませんでした。

アドバイスありがとうございました。
【69310】Re:大量セル書き込みの高速化
回答  UO3  - 11/6/23(木) 21:24 -
引用なし
パスワード
   ▼えすたろう さん：

まずA1からの連続したセル領域、たとえばタイトル行の他にデータが１０行あるとすれば
A1:F11　という全体領域と、そこから１つ下の領域　A2:F12 のAND(Intersect)をとった
データの中身の領域　A2:A11 を myBというRange変数にいれています。
で、それを、どさっとVariant型変数　v に入れることにより、v　は　そのデータの中身が
10行、6列の配列になります。　で、この配列の中で値を生成しているわけです。
で、できあがったものを、シートにどさっと戻すわけですが、
UBound(v,1) は配列の行数、上の例では　10 、UBound(v,2) は配列の列数、上の例では6。
ですから、Range("A2").Resize(10,6) ということになります。
A2を基準にして、10行、6列の領域ということです。
【69311】Re:大量セル書き込みの高速化
発言  UO3  - 11/6/23(木) 21:42 -
引用なし
パスワード
   ▼えすたろう さん：

おまけです。
以下のコードはオリジナルのコードで不要なところをカットし、変数の型を適切なものにして
Application.ScreenUpDating の手当をしたものです。
これでも、効果はありませんか？（少しは早くなりませんかね）

Private Sub 時刻変換_Click()


　　Dim shu As String '出勤時刻
　　Dim tai As String '退勤時刻
　　Dim shuhour As String '出勤時間
　　Dim shumini As String '出勤分
　　Dim taihour As String '退勤時間
　　Dim taimini As String '退勤分
　　Dim shutai As String '配列
　　Dim gyo As Long
　　
　　Application.ScreenUpdating = False
　　
　　With Worksheets("貼り付け")
　　　　gyo = 2

　　　　Do While .Cells(gyo, 1).Value <> ""
　　　　　
　　　　　　　　
　　　　　　shu = .Cells(gyo, 4).Value　'出勤時刻の取り込み
　　　　　　tai = .Cells(gyo, 5).Value　'退勤時刻の取り込み

　　　　　　.Cells(gyo, 8).Value = Left(shu, 2)　'出勤時間の貼り付け
　　　　　　.Cells(gyo, 9).Value = Mid(shu, 3, 2)　'出勤分の貼り付け
　　　　　　.Cells(gyo, 10).Value = Left(tai, 2)　 '退勤時間の貼り付け
　　　　　　.Cells(gyo, 11).Value = Mid(tai, 3, 2)　'退勤分の貼り付け
　　　
　　　　gyo = gyo + 1
　　
　　　　Loop
　　　　
　　End With
　　
　　Application.ScreenUpdating = True
　　
　　MsgBox "完了"

End Sub
【69313】Re:大量セル書き込みの高速化
発言  UO3  - 11/6/23(木) 22:43 -
引用なし
パスワード
   ▼えすたろう さん：

おまけのおまけ

オリジナルのArrayを活かすとすれば、以下のようにすると、↑でアップしたものより
もう少し早くなるはず。

Private Sub 時刻変換_Click()


　　Dim shu As String '出勤時刻
　　Dim tai As String '退勤時刻
　　Dim shuhour As String '出勤時間
　　Dim shumini As String '出勤分
　　Dim taihour As String '退勤時間
　　Dim taimini As String '退勤分
　　Dim shutai As String '配列
　　Dim gyo As Long
　
　　Application.ScreenUpdating = False
　
　　With Worksheets("貼り付け")
　　　　gyo = 2

　　　　Do While .Cells(gyo, 1).Value <> ""
　　
　　　　
　　　　　　shu = .Cells(gyo, 4).Value　'出勤時刻の取り込み
　　　　　　tai = .Cells(gyo, 5).Value　'退勤時刻の取り込み

　　　　　　.Cells(gyo, 8).Resize(, 4).Value = Array(Left(shu, 2), Mid(shu, 3, 2), Left(tai, 2), Mid(tai, 3, 2))

　　　　gyo = gyo + 1
　
　　　　Loop
　　
　　End With
　
　　Application.ScreenUpdating = True
　
　　MsgBox "完了"

End Sub
【69334】Re:大量セル書き込みの高速化
発言  ｍｏｍｏ  - 11/6/27(月) 14:34 -
引用なし
パスワード
   ▼えすたろう さん：

こんなのでも出来そうですね。

Sub test()
With Worksheets("貼り付け").Range(Range("A2"), Range("A2").End(xlDown))
　.TextToColumns Destination:=Range("C2"), DataType:=xlFixedWidth, _
　　　　　　　　 FieldInfo:=Array(Array(0, 2), Array(2, 2)), TrailingMinusNumbers:=True
　.Offset(, 1).TextToColumns Destination:=Range("E2"), DataType:=xlFixedWidth, _
　　　　　　　　 FieldInfo:=Array(Array(0, 2), Array(2, 2)), TrailingMinusNumbers:=True
End With
End Sub
【69337】Re:大量セル書き込みの高速化
発言  UO3  - 11/6/27(月) 15:45 -
引用なし
パスワード
   ▼ｍｏｍｏ さん：

失礼します。
実際のシートは"貼り付け"だけだとは思うのですが、仮に複数シートがあって
実行時、"貼り付け"以外がアクティブであった場合、
With Worksheets("貼り付け").Range(Range("A2"), Range("A2").End(xlDown))
この(Range("A2"), Range("A2").End(xlDown))　これらはその外側の
Worksheets("貼り付け").Rangeと不整合になりませんか？

あと、このWith句の中のRangeが、全て .なしで書かれているのも気になります。
【69338】Re:大量セル書き込みの高速化
発言  ｍｏｍｏ  - 11/6/27(月) 16:02 -
引用なし
パスワード
   ▼UO3 さん：
こんにちは
ご指摘ありがとうございます。
初歩的なミスでしたね。
暗黙のActiveSheetで書いて、後からWorksheetsを付け足したのですが
見落としてました。

Sub test()
With Worksheets("貼り付け")
　With .Range(.Range("A2"), .Range("A2").End(xlDown))
　　.TextToColumns Destination:=.Range("C1"), DataType:=xlFixedWidth, _
　　　　　　　　　 FieldInfo:=Array(Array(0, 2), Array(2, 2)), TrailingMinusNumbers:=True
　　.Offset(, 1).TextToColumns Destination:=.Range("E1"), DataType:=xlFixedWidth, _
　　　　　　　　　 FieldInfo:=Array(Array(0, 2), Array(2, 2)), TrailingMinusNumbers:=True
　End With
End With
End Sub
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
2219 / 13645 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free