Skrifttype ændrer sig ved overførsel fra et ark til et andet
Hejsa,Når jeg med en VBA overfører data fra et ark til et andet, strater den fint ud med Font.FontStyle = "Calibri".
Men efter fx 20 linjer, så skifter den til Ariel.
Hvordan kan det være?
Her er min kode:
Sub Oveførtiltilbud2()
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim LR1 As Long, LR2 As Long, LR3 As Long, LR4 As Long, n As Long, i As Long, b As Long, Lastrow As Long
Set ws1 = Sheets("Kalk")
Set ws2 = Sheets("Tilbud dansk")
Set ws3 = Sheets("Tilbud Engelsk")
Worksheets("Tilbud dansk").Unprotect
ws2.Range("A105:A" & Rows.Count).ClearContents
ws2.Range("B105:B" & Rows.Count).ClearContents
ws2.Range("C105:C" & Rows.Count).ClearContents
ws2.Range("D105:D" & Rows.Count).ClearContents
ws2.Cells.Borders.LineStyle = xlLineStyleNone
LR1 = ws1.Range("B" & Rows.Count).End(xlUp).Row
ActiveSheet.Unprotect
Application.ScreenUpdating = False
LR2 = 105
For i = 10 To LR1
If ws1.Range("B" & i).Value = ("TEKST") And ws1.Range("M" & i).Value = ("JA") Then
ws2.Cells(LR2, "A").Value = ws1.Cells(i, "A").Value
ws2.Cells(LR2, "A").BorderAround xlContinuous
ws2.Cells(LR2, "A").Font.Size = 12
ws2.Cells(LR2, "A").Font.FontStyle = "Calibri"
ws2.Cells(LR2, "B").Value = ws1.Cells(i, "D").Value
ws2.Cells(LR2, "B").BorderAround xlContinuous
ws2.Cells(LR2, "B").Font.Size = 12
ws2.Cells(LR2, "B").Font.FontStyle = "Calibri"
ws2.Cells(LR2, "C").Value = ws1.Cells(i, "AA").Value
ws2.Cells(LR2, "C").BorderAround xlContinuous
ws2.Cells(LR2, "C").Font.Size = 12
ws2.Cells(LR2, "C").Font.FontStyle = "Calibri"
ws2.Cells(LR2, "D").Value = ws1.Cells(i, "AA").Value
ws2.Cells(LR2, "D").BorderAround xlContinuous
ws2.Cells(LR2, "D").Font.Size = 12
ws2.Cells(LR2, "D").Font.FontStyle = "Calibri"
LR2 = LR2 + 1
End If
If ws1.Range("B" & i).Value = "JA" Then
ws2.Cells(LR2, "A").Value = ws1.Cells(i, "A").Value
ws2.Cells(LR2, "A").BorderAround xlContinuous
ws2.Cells(LR2, "A").Font.Size = 12
ws2.Cells(LR2, "A").Font.FontStyle = "Calibri"
ws2.Cells(LR2, "B").Value = ws1.Cells(i, "D").Value
ws2.Cells(LR2, "B").BorderAround xlContinuous
ws2.Cells(LR2, "B").Font.Size = 12
ws2.Cells(LR2, "B").Font.FontStyle = "Calibri"
ws2.Cells(LR2, "C").Value = ws1.Cells(i, "R").Value
ws2.Cells(LR2, "C").BorderAround xlContinuous
ws2.Cells(LR2, "C").Font.Size = 12
ws2.Cells(LR2, "C").Font.FontStyle = "Calibri"
ws2.Cells(LR2, "D").Value = ws1.Cells(i, "Q").Value
ws2.Cells(LR2, "D").BorderAround xlContinuous
ws2.Cells(LR2, "D").Font.Size = 12
ws2.Cells(LR2, "D").Font.FontStyle = "Calibri"
LR2 = LR2 + 1
End If
Next i
' OVERFØRSEL TIL REGNEARK "TILBUD ENGELSK"
Worksheets("Tilbud Engelsk").Unprotect
ws3.Range("A101:A" & Rows.Count).ClearContents
ws3.Range("B101:B" & Rows.Count).ClearContents
ws3.Range("C101:C" & Rows.Count).ClearContents
ws3.Range("D101:D" & Rows.Count).ClearContents
ws3.Cells.Borders.LineStyle = xlLineStyleNone
LR1 = ws1.Range("B" & Rows.Count).End(xlUp).Row
ActiveSheet.Unprotect
LR2 = 101
For i = 10 To LR1
If ws1.Range("B" & i).Value = "JA" Then
ws3.Cells(LR2, "A").Value = ws1.Cells(i, "A").Value
ws3.Cells(LR2, "A").BorderAround xlContinuous
ws3.Cells(LR2, "A").Font.Size = 12
ws2.Cells(LR2, "A").Font.FontStyle = "Calibri"
ws3.Cells(LR2, "B").Value = ws1.Cells(i, "D").Value
ws3.Cells(LR2, "B").BorderAround xlContinuous
ws3.Cells(LR2, "B").Font.Size = 12
ws2.Cells(LR2, "B").Font.FontStyle = "Calibri"
ws3.Cells(LR2, "C").Value = ws1.Cells(i, "R").Value / ws1.Cells(3, "J") ' Omregner DKK til €
ws3.Cells(LR2, "C").BorderAround xlContinuous
ws3.Cells(LR2, "C").Font.Size = 12
ws2.Cells(LR2, "C").Font.FontStyle = "Calibri"
ws3.Cells(LR2, "D").Value = ws1.Cells(i, "Q").Value / ws1.Cells(3, "J") ' Omregner DKK til €
ws3.Cells(LR2, "D").BorderAround xlContinuous
ws3.Cells(LR2, "D").Font.Size = 12
ws2.Cells(LR2, "D").Font.FontStyle = "Calibri"
LR2 = LR2 + 1
End If
Next i
Application.ScreenUpdating = True
' GENLÅSNING AF ARK
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingCells:=True
Worksheets("Tilbud dansk").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingCells:=True
Worksheets("Kalk").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingCells:=True
Worksheets("Tilbud Engelsk").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingCells:=True
End Sub
