Excel - VBA - Kopiera cellområde.

solbulleMedlem sedan mars 20015 287 inlägg

Frågan18 nov. 2003 20:23#1

Nu har jag slitit av alltför många hårstrån... behöver hjälp!

(Excel - VBA)
Jag har ett kalkylblad i Excel där jag till slut får fram två kolumner med värden, i en tredje får jag summan av dessa.
Nu vill jag med en knapptryckning kunna kopiera in ett område från kolumn tre och få dess fasta värden i en kolumn i ett annat blad, samma ark, där kolumnen/området har en cell högst upp med ett värde som den hämtar från en cell i det första arket. :)

Det lät väl enkelt och bra?

solbulleMedlem sedan mars 20015 287 inlägg

18 nov. 2003 20:48#2

Vad ska man säga?

Gäller det Excel - VBA så är det XL-Dennis som gäller.
Stuvade om lite i ett av hans script.

Sub Sok_Hitta_Uppdatera()

   '© 2002 Alla rättigheter XL-Dennis
   '© 2003 Åsså lite rättigheter till Solbulle
   
    Dim rnOmrade As Range, rnVarde As Range
    Dim stAdress As String
    Dim vaVarde As Variant
    Dim rapport As Worksheet
    Dim datablad As Worksheet
     
Set datablad = ActiveWorkbook.Worksheets("Blad1")
Set rapport = ActiveWorkbook.Worksheets("Blad2")

   'Här bestämmer vi cellområdet som ska utsökas.
   Set rnOmrade = rapport.Range("E5:N5")

    vaVarde = ActiveSheet.Range("B3").Value

   'Om användaren avbryter inmatningen
   If vaVarde = False Then Exit Sub

   Application.ScreenUpdating = False

   With rnOmrade

      Set rnVarde = .Find(What:=vaVarde)

      If Not rnVarde Is Nothing Then

         stAdress = rnVarde.Address

         'Här initieras loppen för att hitta celler med det sökta värdet

         Do
            
        datablad.Range("D5:D11").Copy
        rnVarde.Offset(1, 0).PasteSpecial Paste:=xlValues
        Application.CutCopyMode = False

        Set rnVarde = .FindNext(rnVarde)

         Loop While Not rnVarde Is Nothing And rnVarde.Address <> stAdress

         MsgBox "Uppdatering klar.", vbInformation, "Infoga data"

      Else

         MsgBox "Den sökta veckan existerar inte.", vbInformation, "Infoga data"
         Exit Sub

      End If
   End With

   Application.ScreenUpdating = True

 End Sub

Som om man hade gjort det själv.... ;)