VBA til kopiering af Kolonne C + autonummerering

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

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

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

Nu ændre den alle navnene til Råvarer 1, men tilføjer ikke noget.

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

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

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

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?

Pb sendt

Fedt