megoldást keresek erre a problémára
-
Storey #2384 Köszönöm a segítséget, de továbbra sem működik.
Az alábbi makróról lenne szó!
Sub Masolas()
Dim WSJ As Worksheet, WSS As Worksheet, WSA, sor
Dim usor As Integer, sor1 As Integer, sor2 As Integer, sor3 As Integer, sor4 As Integer, sor5 As Integer, sor6 As Integer
Application.ScreenUpdating = False
Set WSS = Sheets("Alap")
Set WSA = Sheets("Második")
Set WSJ = Sheets("Harmadik")
If WSS.Range("E13") = "" Then
MsgBox "Nincsenek másolható adatok!", vbOKOnly + vbExclamation
Exit Sub
End If
'***************************************************************************
'Előző adatok törlése
WSA.Range("C10:G59, C68:G117, C126:G175, C184:G233, C242:G291, C300:G349") = ""
WSJ.Range("C10:G59, C68:G117, C126:G175, C184:G233, C242:G291, C300:G349") = ""
sor1 = 10: sor2 = 68: sor3 = 126: sor4 = 184: sor5 = 242: sor6 = 300
'***************************************************************************
WSS.Select
usor = Range("E12").End(xlDown).Row
For sor = 10 To usor
Select Case Cells(sor, "G")
Case Range("B6").Value
Range("B" & sor & ":F" & sor).Copy
WSA.Range("C" & sor1).PasteSpecial xlPasteValues
Range("B" & sor & ":F" & sor).Copy
WSJ.Range("C" & sor1).PasteSpecial xlPasteValues
sor1 = sor1 + 1
Case Range("B7").Value
Range("B" & sor & ":F" & sor).Copy
WSA.Range("C" & sor2).PasteSpecial xlPasteValues
Range("B" & sor & ":F" & sor).Copy
WSJ.Range("C" & sor2).PasteSpecial xlPasteValues
sor2 = sor2 + 1
Case Range("B8").Value
Range("B" & sor & ":F" & sor).Copy
WSA.Range("C" & sor3).PasteSpecial xlPasteValues
Range("B" & sor & ":F" & sor).Copy
WSJ.Range("C" & sor3).PasteSpecial xlPasteValues
sor3 = sor3 + 1
Case Range("B9").Value
Range("B" & sor & ":F" & sor).Copy
WSA.Range("C" & sor4).PasteSpecial xlPasteValues
Range("B" & sor & ":F" & sor).Copy
WSJ.Range("C" & sor4).PasteSpecial xlPasteValues
sor4 = sor4 + 1
Case Range("B10").Value
Range("B" & sor & ":F" & sor).Copy
WSA.Range("C" & sor5).PasteSpecial xlPasteValues
Range("B" & sor & ":F" & sor).Copy
WSJ.Range("C" & sor5).PasteSpecial xlPasteValues
sor5 = sor5 + 1
Case Range("B11").Value
Range("B" & sor & ":F" & sor).Copy
WSA.Range("C" & sor6).PasteSpecial xlPasteValues
Range("B" & sor & ":F" & sor).Copy
WSJ.Range("C" & sor6).PasteSpecial xlPasteValues
sor6 = sor6 + 1
End Select
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
Range("E13").Select
End Sub
A lényege az, hogy az egyik lapon vegyesen vannak az adatok (max 6 féle) amelyet másik két lapra válogat és másol át.
A makró elindul, de csak az első elemet másolja át a lapokra, a többit nem.
2007 éa 2010 alatt tökéletesen működött, illetve van még jónéhány másik makró is ugyanebben az Excel fileban, amelyek tökéletesen működnek. Csak ez az egy nem. :(
Előre is köszi!