Új hozzászólás Aktív témák

• #43112 zsolti_20 senior tag Delila_1 #43111

  Új Válasz 2020-02-23 15:40:48 #43112

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  zsolti_20

  senior tag

  válasz Delila_1 #43111 üzenetére

  Bedobom ide a teljes kódot, így lesz a legjobb. Kicsi alakítottam rajta, de sajnos mindig errort kapok pont ott ahol el kellene kezdenie átmásolni.
  
  Function getFile() As Workbook
 Dim fn As Variant
 
 fn = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*", Title:="Select workbook")
 If TypeName(fn) <> "Boolean" Then Set getFile = Workbooks.Open(fn)
End Function
Sub useGetFile()
Dim Dic As Object, key As Variant, oCell As Range, i&
 Dim wb1 As Workbook, wb2 As Workbook
 Dim wb1Sheet1 As Worksheet, wb2Sheet1 As Worksheet
 
 Set wb2 = getFile
 If Not wb2 Is Nothing Then
 On Error Resume Next
 Set wb2Sheet1 = wb2.Sheets("Sheet1")
 On Error GoTo 0
 If Not wb2Sheet1 Is Nothing Then
 Set wb1 = Workbooks("1.xlsx")
 Set wb1Sheet1 = wb1.Sheets("Sheet1")
 i = wb1.Cells.SpecialCells(xlCellTypeLastCell).Row
 For Each oCell In wb1.Range("A1:A" & i)
 If Not Dic.exists(oCell.Value) Then
 Dic.Add oCell.Value, oCell.Offset(, 3).Value
 End If
 Next
 i = wb2.Cells.SpecialCells(xlCellTypeLastCell).Row
 For Each oCell In wb2.Range("A2:A" & i)
 For Each key In Dic
 If oCell.Value = key Then
 oCell.Offset(, 2).Value = Dic(key)
 End If
 Next
 Next
 
 
 Else
 MsgBox "Sheet1 not found in " & wb2.Name, vbCritical
 End If
 'Maybe close wb2 here?
 wb2.Close SaveChanges:=False
 Else
 Debug.Print "User cancelled"
 End If
 Set wb1 = Nothing
 Set wb2 = Nothing
 Set wb1Sheet1 = Nothing
 Set wb2Sheet1 = Nothing
End Sub


Új hozzászólás Aktív témák