Excel VBA質問箱 IV

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

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


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

1846 / 76734

←次へ　｜　前へ→


	【80533】Re:処理が遅くなってしまう

amatsuno - 19/2/28(木) 14:05 -


	引用なし

	パスワード

'ログ情報のうち、必要な列のみを抽出

　　ws_master_csv.Columns(2).Copy
　　ws_master_csv_new.Columns(5).PasteSpecial Paste:=xlPasteValues
　
　　ws_master_csv.Columns(8).Copy ws_master_csv_new.Columns(2)
　
　　ws_master_csv.Columns(18).Copy ws_master_csv_new.Columns(3)
　　
　　ws_master_csv.Columns(11).Copy
　　ws_master_csv_new.Columns(4).PasteSpecial Paste:=xlPasteValues
　　ws_master_csv_new.Columns(4).NumberFormatLocal = "h:mm:ss"
　　
　　ws_master_csv.Columns(7).Copy ws_master_csv_new.Columns(1)
　　
　　　　　　　　
　'グループ情報のうち、必要な列のみを抽出
　
　　ws_group.Columns(1).Copy
　　ws_group_new.Columns(1).PasteSpecial Paste:=xlPasteValues
　
　　ws_group.Columns(5).Copy
　　ws_group_new.Columns(2).PasteSpecial Paste:=xlPasteValues
　　　　
　　ws_group.Columns(2).Copy
　　ws_group_new.Columns(3).PasteSpecial Paste:=xlPasteValues
　　
　　　　　　
　'表示名が空白のレコードに、端末機に紐付いている名称を入れる
　　ws_master_csv_new.Columns(5).Copy
　　ws_group_user.Columns(1).PasteSpecial Paste:=xlPasteValues
　
　　ws_master_csv_new.Columns(1).Copy
　　ws_group_user.Columns(2).PasteSpecial Paste:=xlPasteValues
　　　　
　　ws_master_csv.Columns(6).Copy
　　ws_group_user.Columns(3).PasteSpecial Paste:=xlPasteValues
　　
　　　　　　　　　　
　　Const cFormula As String = "=VLOOKUP(@,グループ情報更新!A:C,3,FALSE)"
　　With Worksheets("名称補完")
　　　　Worksheets("利用ユーザ").Range("A:C").Copy .Range("A:A")
　　　　With .Range("A1").CurrentRegion.Columns(2)
　　　　　　If Application.CountBlank(.Cells) > 0 Then
　　　　　　　　With .SpecialCells(xlCellTypeBlanks)
　　　　　　　　.Formula = Replace(cFormula, "@", .Cells(1).Offset(, -1).Address(False, False))
　　　　　　　　End With
　　　　　　.Value = .Value
　　　　　　End If
　　　　End With
　　 End With
　　　　　　　　　　
　　　
　 '名称を入れた表に、実行操作と所要時間を追加する
　　ws_master_csv_new.Columns(3).Copy
　　ws_cover.Columns(4).PasteSpecial Paste:=xlPasteValues
　
　
　　ws_master_csv_new.Columns(4).Copy
　　ws_cover.Columns(5).PasteSpecial Paste:=xlPasteValues
　　ws_cover.Columns(5).NumberFormatLocal = "h:mm:ss"

　　
　　ws_cover.Columns(2).Copy ws_master_csv_new.Columns(1)

　　ws_master_csv_new.Activate
　　

'操作時間を抽出する
　　Dim i4, LastRow As Long
　　LastRow = Cells(Rows.Count, 1).End(xlUp).Row
　　For i4 = 1 To LastRow
　　　　If Cells(i4, 3) = "操作終了" Then
　　　　　　Rows(i4).Copy ws_usetime.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
　　　　End If
　　Next i4

'各ユーザの操作の最も古い時刻と最も新しい時刻を出力結果に抽出する
　　With ws_master_csv_new.Range("A2:D" & ws_master_csv_new.Cells(Rows.Count, 1).End(xlUp).Row)
　　　　v = .Value
　　　　For i = 1 To UBound(v)
　　　　　　m = dic(v(i, 1))
　　　　　　If m = 0 Then
　　　　　　　　n = n + 1
　　　　　　　　v(n, 1) = v(i, 1)
　　　　　　　　v(n, 2) = v(i, 2)
　　　　　　　　v(n, 3) = v(i, 2)
　　　　　　　　dic(v(i, 1)) = n
　　　　　　Else
　　　　　　　　If v(m, 2) > v(i, 2) Then
　　　　　　　　　　v(m, 2) = v(i, 2)
　　　　　　　　End If
　　　　　　　　If v(m, 3) < v(i, 2) Then
　　　　　　　　　　v(m, 3) = v(i, 2)
　　　　　　　　End If
　　　　　　End If
　　　　Next i
　　　　ws_res.Cells(1, 1).Resize(n, .Columns.Count - 1) = v
　　　　
　　End With
　　
　　Set dic = Nothing

　　ws_usetime.Columns(1).Copy
　　ws_usetime_new.Columns(1).PasteSpecial Paste:=xlPasteValues
　　　　
　　ws_usetime.Columns(2).Copy
　　ws_usetime_new.Columns(4).PasteSpecial Paste:=xlPasteValues

　　　　
　　ws_usetime.Columns(3).Copy
　　ws_usetime_new.Columns(3).PasteSpecial Paste:=xlPasteValues
　　　　
　　ws_usetime.Columns(4).Copy
　　ws_usetime_new.Columns(2).PasteSpecial Paste:=xlPasteValues
　　ws_usetime_new.Columns(2).NumberFormatLocal = "h:mm:ss"
　　　　
　　ws_usetime.Columns(5).Copy
　　ws_usetime_new.Columns(5).PasteSpecial Paste:=xlPasteValues
　　
　　
　　ws_addtime.Activate

　　
　　'各ユーザーの利用時間を合算
　With Worksheets("開始終了更新")
　　　For i3 = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
　　　　 vK2 = .Cells(i3, "A").Value
　　　　 dic2(vK2) = dic2(vK2) + .Cells(i3, "B")
　　　Next
　 End With

　 ReDim vA3(1 To dic2.Count, 1 To 2)
　 i3 = 0
　 For Each vK2 In dic2.Keys
　　　i3 = i3 + 1
　　　vA3(i3, 1) = vK2
　　　vA3(i3, 2) = dic2(vK2)
　 Next

　 Application.ScreenUpdating = False
　 With Worksheets("時間合計")
　　　With .Range("A1").Resize(i3, 2)
　　　　 .EntireColumn.ClearContents
　　　　 .Value = vA3
　　　　 .Columns(2).NumberFormatLocal = "h:mm:ss"
　　　　 Application.Goto .Cells(1), True
　　　End With
　 End With
　 Application.ScreenUpdating = True

　 Rows(1).Insert

　 Set dic2 = Nothing

　　 'ここで、マスタCSVから取得⇒配列にいれる列を指定

　　ws_res.Columns(3).Copy
　　ws_last.Columns(1).PasteSpecial Paste:=xlPasteValues
　　ws_last.Columns(1).NumberFormatLocal = "yyyy/m/d"
　　
　　ws_res.Columns(1).Copy
　　ws_last.Columns(3).PasteSpecial Paste:=xlPasteValues
　　
　　
　　ws_res.Columns(2).Copy
　　ws_last.Columns(4).PasteSpecial Paste:=xlPasteValues
　　ws_last.Columns(4).NumberFormatLocal = "h:mm:ss"
　　
　　ws_res.Columns(3).Copy
　　ws_last.Columns(5).PasteSpecial Paste:=xlPasteValues
　　ws_last.Columns(5).NumberFormatLocal = "h:mm:ss"
　
　　
　　ws_addtime.Columns(2).Copy
　　ws_last.Columns(6).PasteSpecial Paste:=xlPasteValues
　　ws_last.Columns(6).NumberFormatLocal = "h:mm:ss"
　　
　　
　　ws_addtime.Rows(1).Delete
　　　
　　ws_last.Activate
　
　　Rows(1).Insert

　　Range("A1").Value = "日付"
　　Range("B1").Value = "部署"
　　Range("C1").Value = "ｴｰｼﾞｪﾝﾄ"
　　Range("D1").Value = "ON"
　　Range("E1").Value = "OFF"
　　Range("F1").Value = "稼働時間"

　　ws_group_new.Columns(3).Copy
　　ws_group_new_2.Columns(1).PasteSpecial Paste:=xlPasteValues
　
　　
　　ws_group_new.Columns(2).Copy
　　ws_group_new_2.Columns(3).PasteSpecial Paste:=xlPasteValues
　　
　　
　　ws_group_new.Columns(1).Copy
　　ws_group_new_2.Columns(2).PasteSpecial Paste:=xlPasteValues
　　
　　ws_last.Columns(3).Copy
　　ws_group_new_3.Columns(1).PasteSpecial Paste:=xlPasteValues
　
　　
　　ws_last.Columns(2).Copy
　　ws_group_new_3.Columns(2).PasteSpecial Paste:=xlPasteValues
　　
　　
　　ws_last.Columns(1).Copy
　　ws_group_new_3.Columns(3).PasteSpecial Paste:=xlPasteValues

　　Const cFormula2 As String = "=VLOOKUP(@,グループ補完2!A:C,3,FALSE)"
　　With Worksheets("グループ名")
　　　　Worksheets("グループ補完").Range("A:C").Copy .Range("A:A")
　　　　With .Range("A1").CurrentRegion.Columns(2)
　　　　　　If Application.CountBlank(.Cells) > 0 Then
　　　　　　　　With .SpecialCells(xlCellTypeBlanks)
　　　　　　　　.Formula = Replace(cFormula2, "@", .Cells(1).Offset(, -1).Address(False, False))
　　　　　　　　End With
　　　　　　.Value = .Value
　　　　　　End If
　　　　End With
　　 End With

　　ws_group_name.Columns(2).Copy
　　ws_last.Columns(2).PasteSpecial Paste:=xlPasteValues
　　

　　 ws_last.Activate
　　
　　With Range("b2:b30000")
　　.Replace what:="#N/A", replacement:="dummy", lookat:=xlWhole
　　End With

　　　　
'　　ws_last.SaveAs "P:\fileexp.csv", FileFormat:=xlCSV, Local:=True

　 '初期画面に戻る
　　ws_btn.Activate
　　
　　　　　　
　　Debug.Print Time
　　
　　'処理の終了
　　Close #intFree
　　Close #intFree2
　　
　 Call MsgBox("取り込みが完了しました。", vbSystemModal)
'　　Application.DisplayAlerts = False 'メッセージを非表示設定に変更
'　　Application.Quit
'　　Workbooks.Close
'　　Application.DisplayAlerts = True　'メッセージを表示設定に変更
　　　　
End Sub

9 hits

▼

【80532】処理が遅くなってしまう amatsuno 19/2/28(木) 14:04