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

• #23728 Fferi50 Topikgazda slashing #23726

  Új Válasz 2014-10-15 11:31:42 #23728

  Ú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

  

  Fferi50

  Topikgazda

  válasz slashing #23726 üzenetére

  Szia!

  Azért javaslom, nézd meg ezt is. Egyetlen követelmény, hogy a másolandó adatok az első oszlopban kövessék egymást - úgy ahogyan a képeken is van.

  Sub masolo()
  Dim mlap1 As Worksheet, masolando As Range, mlap2 As Worksheet, hovasor As Double, hovaoszlop As Double
  Set mlap1 = Workbooks("Munkafüzet3").Sheets("Munka1")
  Set mlap2 = Workbooks("Munkafüzet4").Sheets("Munka1")
  Set terulet = mlap2.UsedRange
  hovasor = terulet.Rows.Count
  If terulet.Cells(1, hovasor) = "" Then
  Do While True
  If terulet(1, hovasor).End(xlToRight).Column < terulet.Columns.Count Then Exit Do
  hovasor = hovasor - 1
  Loop
  End If
  hovasor = hovasor + 1
  Set terulet = mlap1.Range("A1").CurrentRegion
  Do While True
  For oszlop = 1 To terulet.Columns.Count
  hovaoszlop = Application.IfError(Application.Match(terulet.Cells(1, oszlop), mlap2.Rows("1:1"), 0), 0)
  If hovaoszlop <> 0 Then
  Intersect(terulet, terulet.Offset(1, 0)).Columns(oszlop).Copy mlap2.Cells(hovasor, hovaoszlop)
  End If
  Next
  hovasor = hovasor + terulet.Rows.Count - 1
  Set terulet = terulet.Range("A1").End(xlDown).End(xlDown).CurrentRegion
  If Intersect(mlap1.UsedRange, terulet) Is Nothing Then Exit Do
  Loop
  MsgBox "A másolás megtörtént!", vbInformation, "Másolás"
  End Sub

  Üdv.

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