Tilpasse makro
Jeg har en listbox som er inbygget i arket dvs.ikke på formen. Brugeren vælger et emne ad gangen og så kører makro som kopirer en kolonne fra andre ark og indsætter dem i ark1. Jeg vil gerne have at makro ikke kan skrive i kolonnerne efter kolonne G og at den kommer med en message box.Private Sub ListBox1_Click()
Dim rFound As Range
Dim rLook As Range
Dim rValue As String
Dim rDest As Range
rValue = ListBox1.Value
Set rLook = Worksheets("Axe").Range("c2:aw2")
Set rFound = rLook.Find(rValue, , , xlWhole)
If Not rFound Is Nothing Then
rFound.Resize(44, 1).Copy
With Worksheets("Ark1")
With .Range("IV29").End(xlToLeft).Offset(0, 1)
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteComments
Selection.HorizontalAlignment = xlCenter
End With
End With
End If
Set rLook = Worksheets("Dax").Range("c2:aw2")
Set rFound = rLook.Find(rValue, , , xlWhole)
If Not rFound Is Nothing Then
rFound.Resize(44, 1).Copy
With Worksheets("Ark1")
With .Range("IV29").End(xlToLeft).Offset(0, 1)
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteComments
Selection.HorizontalAlignment = xlCenter
End With
End With
End If
Set rLook = Worksheets("Rix").Range("c2:aw2")
Set rFound = rLook.Find(rValue, , , xlWhole)
If Not rFound Is Nothing Then
rFound.Resize(44, 1).Copy
With Worksheets("Ark1")
With .Range("IV29").End(xlToLeft).Offset(0, 1)
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteComments
Selection.HorizontalAlignment = xlCenter
End With
End With
End If
Set rLook = Worksheets("Vix").Range("c2:aw2")
Set rFound = rLook.Find(rValue, , , xlWhole)
If Not rFound Is Nothing Then
rFound.Resize(44, 1).Copy
With Worksheets("Ark1")
With .Range("IV29").End(xlToLeft).Offset(0, 1)
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteComments
Selection.HorizontalAlignment = xlCenter
End With
End With
End If
End Sub
