Sub TEST()
  Dim ar, r As Long, i As Long
  Dim cIndexOld, cIndexNew, arNewHeader
  Dim f
  
  cIndexOld = Array(4, 5) 'A檔案中要搬動的欄
  cIndexNew = Array(4, 5)  '搬到B檔位置(欄號)
  arNewHeader = Array("新戶籍地址", "新通訊地址") 'B檔標題名稱
  
  f = Application.GetOpenFilename(FileFilter:="Excel 活頁簿 (*.xls),*.xls", Title:="選擇來源檔案")
  If Not TypeName(f) = "String" Then Exit Sub '取消則結束
  
  Application.ScreenUpdating = False
  With Workbooks.Open(f)
    With .Sheets(1)
      ar = .Range("A2:E" & .[A2].CurrentRegion.Rows.Count).Value
    End With
    .Close False
  End With
  Application.ScreenUpdating = True
  
  r = UBound(ar)
  With Workbooks.Add
    With .Sheets(1)
      For i = LBound(cIndexOld) To UBound(cIndexOld)
        .Cells(1, cIndexNew(i)).Resize(r).Value = Application.WorksheetFunction.Index(ar, 0, cIndexOld(i))
        .Cells(1, cIndexNew(i)).Value = arNewHeader(i)
      Next

    End With
  End With
  

   
End Sub