fork download
copy 
  1. Option Explicit
  2.  
  3. Const Scrbook As String = "移動元.xlsx"
  4. Const Folder As String = "D:\goo\data"
  5. Public Sub 転記()
  6.     Dim t0, t1, t2, t3
  7.     Dim dict As Object
  8.     Dim maxrow3 As Long
  9.     Dim row3 As Long
  10.     Dim key2 As Variant
  11.     Dim sh3 As Worksheet
  12.     Dim Vals As Variant
  13.     Dim sname As String
  14.     Dim row2 As Long
  15.  
  16.     Application.ScreenUpdating = False
  17.     Application.Calculation = xlCalculationManual
  18.     t0 = Time
  19.     Set dict = CreateObject("Scripting.Dictionary")
  20.     Workbooks.Open Filename:=Folder & "\" & Scrbook, ReadOnly:=True, UpdateLinks:=0
  21.     t1 = Time
  22.     Call GetlDs("移動元", dict)
  23.     t2 = Time
  24.     ThisWorkbook.Activate
  25.     Set sh3 = Worksheets("Sheet1")
  26.     maxrow3 = sh3.Cells((Rows.Count), "F").End(xlUp).row
  27.  
  28.     For row3 = 4 To maxrow3
  29.         key2 = sh3.Cells(row3, "F").Value
  30.  
  31.         If dict.exists(key2) = True And sh3.Cells(row3, "H") = "" Then
  32.             Vals = Split(dict(key2), "|")
  33.             sname = Vals(0)
  34.             row2 = Vals(1)
  35.             sh3.Cells(row3, "E").Value = Workbooks(Scrbook).Worksheets(sname).Cells(row2, "C").Value
  36.  
  37.             sh3.Cells(row3, "G").Value = Workbooks(Scrbook).Worksheets(sname).Cells(row2, "Z").Value
  38.             sh3.Cells(row3, "H").Value = Workbooks(Scrbook).Worksheets(sname).Cells(row2, "H").Value
  39.             sh3.Cells(row3, "I").Value = Workbooks(Scrbook).Worksheets(sname).Cells(row2, "G").Value
  40.             sh3.Cells(row3, "J").Value = Workbooks(Scrbook).Worksheets(sname).Cells(row2, "L").Value
  41.             sh3.Cells(row3, "K").Value = Workbooks(Scrbook).Worksheets(sname).Cells(row2, "K").Value
  42.             sh3.Cells(row3, "M").Value = Workbooks(Scrbook).Worksheets(sname).Cells(row2, "DQ").Value
  43.             sh3.Cells(row3, "O").Value = Workbooks(Scrbook).Worksheets(sname).Cells(row2, "T").Value
  44.             sh3.Cells(row3, "P").Value = Workbooks(Scrbook).Worksheets(sname).Cells(row2, "V").Value
  45.  
  46.         Else
  47.             'sh3.Cells(row, "E").Value = ""
  48.             'sh3.Cells(row, "G").Value = ""
  49.             'sh3.Cells(row, "H").Value = ""
  50.             'sh3.Cells(row, "I").Value = ""
  51.             'sh3.Cells(row, "J").Value = ""
  52.             'sh3.Cells(row, "K").Value = ""
  53.             'sh3.Cells(row, "M").Value = ""
  54.             'sh3.Cells(row, "O").Value = ""
  55.             'sh3.Cells(row, "P").Value = ""
  56.  
  57.         End If
  58.     Next
  59.     t3 = Time
  60.     Workbooks(Scrbook).Close
  61.  
  62.     Application.Calculation = xlCalculationAutomatic
  63.     Application.ScreenUpdating = True
  64.     Debug.Print "転記"
  65.     Debug.Print "Open", 86400 * (t1 - t0)
  66.     Debug.Print "GetIDs", 86400 * (t2 - t1)
  67.     Debug.Print "Sheet1", 86400 * (t3 - t2)
  68.     MsgBox ("完了")
  69. End Sub
  70.  
  71. Private Sub GetlDs(ByVal sname As String, ByRef dict As Object)
  72.  
  73.     Dim maxrow As Long
  74.     Dim row As Long
  75.     Dim key As Variant
  76.     Dim sh3 As Worksheet
  77.     Set sh3 = Worksheets(sname)
  78.     maxrow = sh3.Cells((Rows.Count), "A").End(xlUp).row    'ID
  79.     For row = 2 To maxrow
  80.         key = sh3.Cells(row, "A")
  81.         dict(key) = sname & "|" & row
  82.     Next
  83. End Sub
  84.  
Not running #stdin #stdout 0s 0KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
Standard output is empty
https://ideone.com/zILYjq
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!