Avatar billede chrcms Novice
12. april 2017 - 11:13 Der er 9 kommentarer og
1 løsning

VBA til kopiering af Kolonne C + autonummerering

Hejsa eksperter

Jeg har brug for at kunne lave en VBA knap som kopiere Række C2-C42, den hedder Råvarer 1. Derefter skal den indsætter en kolonne lige efter som så hedder Råvarer 2, Råvarer 3, Råvarer 4 osv. med automatisk nummerering.

Selve arket hedder "Råvarer"

Derefter har jeg behov for en som er næsten identisk som til Emballage 1, Emballage 2 som den kopiere fra I2-I42
Avatar billede Jan Hansen Ekspert
12. april 2017 - 20:20 #1
Hej
forventer der står Råvarer 1 i C1 og Emballage1 i I1

Option Explicit
Dim ws As Worksheet
Dim rRaavare1 As Range, rEmbla1 As Range
Dim rKopi As Range, rX As Range
Dim iStartRow As Integer, iEndRow As Integer, iAntalKopi As Integer
Const iColC As Integer = 3  'sætter c kolonnen
Const iColI As Integer = 9
Dim iCount As Integer
Private Sub SetVar()
    Set ws = Sheets("Råvarer") 'sætter ws = arket Råvarer
    iStartRow = 2  ' sætter start rækken
    iEndRow = 42    ' sætter slut rækken
    iAntalKopi = 5  ' sætter antal kopikolonner
    Set rRaavare1 = ws.Range(Cells(iStartRow, iColC), Cells(iEndRow, iColC))
    Set rEmbla1 = ws.Range(Cells(iStartRow, iColI), Cells(iEndRow, iColI))
End Sub
Sub KopiKnap()
    SetVar
    Call Kopi(iColC, rRaavare1) ' kopier C
    Call Kopi(iColI, rEmbla1)  ' kopier I
End Sub
Private Sub Kopi(iCol As Integer, r1 As Range)
    Set rKopi = ws.Cells(1, iCol)
    For iCount = 1 To iAntalKopi
        rKopi.Offset(0, 1).Value = Left(rKopi.Value, Len(rKopi.Value) - 1)
        rKopi.Offset(0, 1).Value = rKopi.Offset(0, 1).Value & Right(rKopi.Value, 1) + 1
        Set rKopi = rKopi.Offset(0, 1)
        Set rX = Range(Cells(iStartRow, iCol + iCount), Cells(iEndRow, iCol + iCount))
        rX.Value = r1.Value
    Next iCount
End Sub

Mvh Jan
Avatar billede chrcms Novice
19. april 2017 - 11:32 #2
Hej Jan

Jeg har lige prøvet at linke til excel-arket, så du kan se det med egne øjne.
Jeg fik en compile error.

https://1drv.ms/x/s!AkLug52fEsq9yHHFBh3jX7lIpSVu
Avatar billede Jan Hansen Ekspert
19. april 2017 - 12:15 #3
Prøv nedenstående:

Option Explicit
Dim ws As Worksheet
Dim rRaavare1 As Range, rEmbla1 As Range
Dim rKopi As Range, rX As Range
Dim iStartRow As Integer, iEndRow As Integer, iAntalKopi As Integer
Const iColC As Integer = 3  'sætter c kolonnen
Const iColI As Integer = 9
Dim iCount As Integer

Sub Knap112_Klik()
    SetVar
    Call Kopi(iColC, rRaavare1) ' kopier C
End Sub
Sub Knap113_Klik()
    SetVar
    Call Kopi(iColI, rEmbla1)  ' kopier I
End Sub
Private Sub SetVar()
    Set ws = Sheets("Råvarer") 'sætter ws = arket Råvarer
    iStartRow = 2  ' sætter start rækken
    iEndRow = 42    ' sætter slut rækken
    iAntalKopi = 5  ' sætter antal kopikolonner
    Set rRaavare1 = ws.Range(Cells(iStartRow, iColC), Cells(iEndRow, iColC))
    Set rEmbla1 = ws.Range(Cells(iStartRow, iColI), Cells(iEndRow, iColI))
End Sub
Private Sub Kopi(iCol As Integer, r1 As Range)
    Set rKopi = ws.Cells(iStartRow, iCol)
    For iCount = 1 To iAntalKopi
        rKopi.Offset(0, 1).Value = Left(rKopi.Value, Len(rKopi.Value) - 1)
        rKopi.Offset(0, 1).Value = rKopi.Offset(0, 1).Value & Right(rKopi.Value, 1) + 1
        Set rKopi = rKopi.Offset(0, 1)
        Set rX = Range(Cells(iStartRow, iCol + iCount), Cells(iEndRow, iCol + iCount))
        rX.Value = r1.Value
    Next iCount
End Sub

Indsættes i et modul

ps. dine checkbokse kan for nuværende ikke noget aktivt (laves beregninger ud fra



Jan
Avatar billede chrcms Novice
20. april 2017 - 09:37 #4
Nu ændre den alle navnene til Råvarer 1, men tilføjer ikke noget.
Avatar billede Jan Hansen Ekspert
20. april 2017 - 09:56 #5
Det havde jeg ikke lige set!!
her er en rettet ver af sub Kopi

Private Sub Kopi(iCol As Integer, r1 As Range)
    Set rKopi = ws.Cells(iStartRow, iCol)
    Set r1 = r1.Offset(1, 0)
    For iCount = 1 To iAntalKopi
        rKopi.Offset(0, 1).Value = Left(rKopi.Value, Len(rKopi.Value) - 1)
        rKopi.Offset(0, 1).Value = rKopi.Offset(0, 1).Value & Right(rKopi.Value, 1) + 1
        Set rKopi = rKopi.Offset(0, 1)
        Set rX = Range(Cells(iStartRow + 1, iCol + iCount), Cells(iEndRow, iCol + iCount))
        rX.Value = r1.Value
    Next iCount
End Sub
Avatar billede Jan Hansen Ekspert
20. april 2017 - 10:01 #6
hvad mener du med den ikke tilføjer noget?
hvis der står noget i c3 bliver det kopiret til d3

dine checkbokse skal laves med vba hvis man skal arbejde med dem da de skal have unikke navne som der kan loopes gennem.

Jan
Avatar billede Jan Hansen Ekspert
20. april 2017 - 10:30 #7
ups har lige lavet en lille rettelse da styringen af antal kopierede kolonner ikke var rigtig

Option Explicit
Dim ws As Worksheet
Dim rRaavare1 As Range, rEmbla1 As Range
Dim rKopi As Range, rX As Range
Dim iStartRow As Integer, iEndRow As Integer, iAntalKopi As Integer
Const iColC As Integer = 3  'sætter c kolonnen
Const iColI As Integer = 9
Dim iCount As Integer
Sub Knap112_Klik()
    SetVar
    iAntalKopi = 5    ' sætter antal kopikolonner
    Call Kopi(iColC, rRaavare1) ' kopier C
End Sub
Sub Knap113_Klik()
    SetVar
    iAntalKopi = 1    ' sætter antal kopikolonner
    Call Kopi(iColI, rEmbla1)  ' kopier I
End Sub
Private Sub SetVar()
    Set ws = Sheets("Råvarer") 'sætter ws = arket Råvarer
    iStartRow = 2  ' sætter start rækken
    iEndRow = 42    ' sætter slut rækken
    Set rRaavare1 = ws.Range(Cells(iStartRow, iColC), Cells(iEndRow, iColC))
    Set rEmbla1 = ws.Range(Cells(iStartRow, iColI), Cells(iEndRow, iColI))
End Sub
Private Sub Kopi(iCol As Integer, r1 As Range)
    Set rKopi = ws.Cells(iStartRow, iCol)
    Set r1 = r1.Offset(1, 0)
    For iCount = 1 To iAntalKopi
        rKopi.Offset(0, 1).Value = Left(rKopi.Value, Len(rKopi.Value) - 1)
        rKopi.Offset(0, 1).Value = rKopi.Offset(0, 1).Value & Right(rKopi.Value, 1) + 1
        Set rKopi = rKopi.Offset(0, 1)
        Set rX = Range(Cells(iStartRow + 1, iCol + iCount), Cells(iEndRow, iCol + iCount))
        rX.Value = r1.Value
    Next iCount
End Sub
Avatar billede chrcms Novice
01. maj 2017 - 10:59 #8
Hej Jan

Jeg synes ikke at kunne få det til at virke.
Nu skifter den Emballage 1 til Varer 6

Kan jeg sende Excel-arket til dig?
Avatar billede Jan Hansen Ekspert
01. maj 2017 - 11:18 #9
Pb sendt
Avatar billede Jan Hansen Ekspert
04. maj 2017 - 08:12 #10
Fedt
Avatar billede Ny bruger Nybegynder

Din løsning...

Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.

Loading billede Opret Preview
Kategori
Vi har et stort udvalg af Excel kurser. Find lige det kursus der passer dig lige her.

Log ind eller opret profil

Hov!

For at kunne deltage på Computerworld Eksperten skal du være logget ind.

Det er heldigvis nemt at oprette en bruger: Det tager to minutter og du kan vælge at bruge enten e-mail, Facebook eller Google som login.

Du kan også logge ind via nedenstående tjenester