fork download
copy 
  1. Option Explicit
  2. Const Scrbook As String = "転記元.xlsx"
  3. Const Folder As String = "D:\goo\data"
  4.  
  5. Public Sub メモリ転記()
  6.     Dim t0, t1, t2, t3
  7.     Dim dict As Object
  8.     Dim sh1 As Worksheet    '転記元ワークシート
  9.     Dim sh2 As Worksheet    '転記先ワークシート
  10.     Dim maxrow1 As Long     '転記元最大行番号　A列
  11.     Dim maxrow2 As Long     '転記先最大行番号　F列
  12.     Dim row1 As Long        '転記元
  13.     Dim row2 As Long        '転記先
  14.     Dim key As Variant      '転記元
  15.     Dim key2 As Variant     '転記先
  16.     Dim Carr As Variant     '転記元 C列配列
  17.     Dim Zarr As Variant     '転記元 Z列配列
  18.     Dim Harr As Variant     '転記元 H列配列
  19.     Dim Garr As Variant     '転記元 G列配列
  20.     Dim Larr As Variant     '転記元 L列配列
  21.     Dim Karr As Variant     '転記元 K列配列
  22.     Dim DQarr As Variant    '転記元 DQ列配列
  23.     Dim Tarr As Variant     '転記元 T列配列
  24.     Dim Varr As Variant     '転記元 V列配列
  25.     Dim no As Long          'no
  26.     Application.ScreenUpdating = False
  27.     Application.Calculation = xlCalculationManual
  28.     Set sh2 = Worksheets("Sheet1")
  29.     maxrow2 = sh2.Cells((Rows.Count), "F").End(xlUp).row
  30.     Set dict = CreateObject("Scripting.Dictionary")
  31.  
  32.     t0 = Time
  33.     Workbooks.Open Filename:=Folder & "\" & Scrbook, ReadOnly:=True, UpdateLinks:=0
  34.     t1 = Time
  35.     Set sh1 = Worksheets("転記元")
  36.     maxrow1 = sh1.Cells((Rows.Count), "A").End(xlUp).row    'ID
  37.     For row1 = 2 To maxrow1
  38.         key = sh1.Cells(row1, "A")
  39.         dict(key) = row1 - 2 + 1
  40.     Next
  41.     Call GetArray(sh1, 2, maxrow1, "C", Carr)
  42.     Call GetArray(sh1, 2, maxrow1, "Z", Zarr)
  43.     Call GetArray(sh1, 2, maxrow1, "H", Harr)
  44.     Call GetArray(sh1, 2, maxrow1, "G", Garr)
  45.     Call GetArray(sh1, 2, maxrow1, "L", Larr)
  46.     Call GetArray(sh1, 2, maxrow1, "K", Karr)
  47.     Call GetArray(sh1, 2, maxrow1, "DQ", DQarr)
  48.     Call GetArray(sh1, 2, maxrow1, "T", Tarr)
  49.     Call GetArray(sh1, 2, maxrow1, "V", Varr)
  50.     t2 = Time
  51.     For row2 = 4 To maxrow2
  52.         key2 = sh2.Cells(row2, "F").Value
  53.         If dict.exists(key2) = True And sh2.Cells(row2, "H") = "" Then
  54.             no = dict(key2)
  55.             sh2.Cells(row2, "E").Value = Carr(no, 1)
  56.             sh2.Cells(row2, "G").Value = Zarr(no, 1)
  57.             sh2.Cells(row2, "H").Value = Harr(no, 1)
  58.             sh2.Cells(row2, "I").Value = Garr(no, 1)
  59.             sh2.Cells(row2, "J").Value = Larr(no, 1)
  60.             sh2.Cells(row2, "K").Value = Karr(no, 1)
  61.             sh2.Cells(row2, "M").Value = DQarr(no, 1)
  62.             sh2.Cells(row2, "O").Value = Tarr(no, 1)
  63.             sh2.Cells(row2, "P").Value = Varr(no, 1)
  64.         End If
  65.     Next
  66.     t3 = Time
  67.     Workbooks(Scrbook).Close
  68.     Application.Calculation = xlCalculationAutomatic
  69.     Application.ScreenUpdating = True
  70.     Debug.Print "メモリ転記"
  71.     Debug.Print "Open", 86400 * (t1 - t0)
  72.     Debug.Print "GetIDs", 86400 * (t2 - t1)
  73.     Debug.Print "Sheet1", 86400 * (t3 - t2)
  74.     MsgBox ("完了")
  75. End Sub
  76. Private Sub GetArray(ByVal ws As Worksheet, ByVal srow As Long, ByVal erow As Long, ByVal col As String, ByRef arr As Variant)
  77.     Dim rg As String
  78.     rg = col & srow & ":" & col & erow
  79.     arr = ws.Range(rg).Value
  80. End Sub
  81.  
  82.  
Not running #stdin #stdout 0s 0KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
Standard output is empty
https://ideone.com/BFxAls
language:
Text (text 6.10)
created:
1 year ago
visibility:
secret

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!