Avatar billede dantyr Juniormester
03. juli 2015 - 20:49 Der er 7 kommentarer og
1 løsning

Macro med 2 celler samlet i en i 2 rækker

:jeg har en række i ark "Serie" (I2:I1000) hvor den tekst der står der i bliver skrevet antal gange som celle H2:H1000 angiver (i samme række). De bliver skrevet ind i et nyt ark "Labels" feks hvis der står i celler "H2" står tallet "3" og i celle "I3" står tallet "55" så vil min macro skrive 55 tre gange på ark "Labels" fra celle "A1 til C1".
Jeg vil nu gerne ha at der der står i ark "Serie" Række"G2:G1000" kommer med i samme række på ark "Labels". Men det skal stå under det fra række "I" og med en anden tekst størrelse samt skrift.

Mit excel ark er her......http://www.filedropper.com/1528ny-2
Avatar billede supertekst Ekspert
05. juli 2015 - 18:15 #1
Rem Kode til opbygning af det ønskede for en række.
Rem Integreres med bestående kode.

Sub test()
Const Serieræk = 107                    'Test
Dim LabelsRæk As Integer
Dim serieData As String, gruppeData As String, labelsData As String
Dim startPosSerie As Integer
    LabelsRæk = 1
   
    With ActiveWorkbook.Sheets("Serie")
        serieData = .Range("I" & Serieræk)
        gruppeData = .Range("G" & Serieræk)
       
        labelsData = serieData & vbCrLf & gruppeData
    End With

    ActiveSheet.Range("A" & LabelsRæk) = labelsData
    startPosSerie = InStr(labelsData, gruppeData)
    If startPosSerie > 0 Then
        formaterSerie startPosSerie, Len(serieData)
    End If
   
    ActiveSheet.Columns.AutoFit
End Sub
Private Sub formaterSerie(startPos, lgdSerie)
    With ActiveCell.Characters(Start:=startPos, Length:=lgdSerie).Font
        .Name = "Arial Narrow"          '<------- Eksempel
        .Size = 12                      '<------- - " -
    End With
End Sub
Avatar billede dantyr Juniormester
05. juli 2015 - 22:19 #2
Det virker men jeg er da godt nok lost med at få dem bygget sammen.
Avatar billede dantyr Juniormester
05. juli 2015 - 22:20 #3
Public Sub Labels()
    Dim Data As Variant, i As Integer, K As Integer, Col As Integer, Rw As Integer
    RK = Worksheets("Serie").Range("I1").End(xlDown).Row
    Data = Worksheets("Serie").Range("H1:I1" & RK)
    Col = 0
    Rw = 1
   

    For i = 2 To UBound(Data, 1)
        For K = 1 To Data(i, 1)
            Col = Col + 1
            If Col = 6 Then
                Col = 1
                Rw = Rw + 1
            End If

            Worksheets("Labels").Cells(Rw, Col) = Data(i, 2)    'ret Ark2 til dit labelsark
Avatar billede supertekst Ekspert
05. juli 2015 - 23:14 #4
Vender tilbage..
Avatar billede dantyr Juniormester
05. juli 2015 - 23:23 #5
mange tak :). Jeg har problemer med at forstå selv den jeg bruger nu, prøver at bytte rundt på det hele for at se hvad er hvad. Men det giver ikke meget mening for mig
Avatar billede supertekst Ekspert
06. juli 2015 - 12:59 #6
Version 2

Dim Data As Variant, i As Integer, K As Integer, Col As Integer, Rw As Integer
Public Sub MakeLabels()
Dim serieData As String, typeData As String, startPos As Integer, labelsData As String
    RK = Worksheets("Serie").Range("I1").End(xlDown).Row
    Data = Worksheets("Serie").Range("H1:I1" & RK)
    Col = 0
    Rw = 1
   
    For i = 2 To UBound(Data, 1)
   
        For K = 1 To Data(i, 1)
            Col = Col + 1
            If Col = 6 Then
                Col = 1
                Rw = Rw + 1
            End If
           
            serieData = Data(i, 2)
           
            With ActiveWorkbook.Sheets("Serie")
                typeData = .Range("G" & Rw + 1)
                labelsData = serieData & vbCrLf & typeData
                startPos = InStr(labelsData, typeData)
            End With
           
            Worksheets("Labels").Cells(Rw, Col) = Data(i, 2) & vbCrLf & Sheets("Serie").Range("G" & Rw + 1)
           
            formaterLabel startPos, Len(typeData)
        Next K
        Sheets("Serie").Activate
    Next i
   
    Worksheets("Labels").Columns.AutoFit
End Sub
Private Sub formaterLabel(startPos, lgdSerie)

    If startPos > 0 Then
        With Sheets("Labels").Cells(Rw, Col).Characters(Start:=startPos, Length:=lgdSerie).Font
            .Name = "Arial Narrow"          '<------- Eksempel
            .Size = 12                      '<------- - " -
        End With
    End If
End Sub
Avatar billede dantyr Juniormester
06. juli 2015 - 15:19 #7
Fedt det virker. Mange tak vil lige bruge noget tid på at finde ud af hvordan det helt virker. Mange mange tak
Avatar billede supertekst Ekspert
06. juli 2015 - 16:34 #8
Ellers kan du blot spørge.
Fint det virker og selv tak
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