Excel VBA Retain colour of text

dmcg9760 · #1 09-05-2016, 07:34 PM

Good Morning

Having a issue working out Excel VBA when capturing data from one sheet to another, as the sheet works through I would like to retain the Original Text color and Bold Font of the text as per below Original Data, Have attached copy of Original Data and the current Captured Data.

Any help on this would be much appreciated

Regards
David

Original Data

14 FORTHEFUNOFIT14 FORTHEFUNOFIT14 FORTHEFUNOFIT4 WHITE DEVON6 PRINCE JESTER14 FORTHEFUNOFIT14 FORTHEFUNOFIT4 WHITE DEVON6 PRINCE JESTER3 MISTER ZAO10 KEMPSIDE4 WHITE DEVON4 WHITE DEVON1 AMBASSADOR LAD2 HIGH CALL4 WHITE DEVON6 PRINCE JESTER6 PRINCE JESTER10 KEMPSIDE6 PRINCE JESTER2 HIGH CALL6 PRINCE JESTER3 MISTER ZAO1 AMBASSADOR LAD 7 SILVER COIN 14 FORTHEFUNOFIT1 AMBASSADOR LAD3 MISTER ZAO

Current Captured Data Output

14 FORTHEFUNOFIT14 FORTHEFUNOFIT14 FORTHEFUNOFIT4 WHITE DEVON6 PRINCE JESTER14 FORTHEFUNOFIT14 FORTHEFUNOFIT4 WHITE DEVON6 PRINCE JESTER3 MISTER ZAO10 KEMPSIDE4 WHITE DEVON4 WHITE DEVON1 AMBASSADOR LAD2 HIGH CALL4 WHITE DEVON6 PRINCE JESTER6 PRINCE JESTER10 KEMPSIDE6 PRINCE JESTER2 HIGH CALL6 PRINCE JESTER3 MISTER ZAO1 AMBASSADOR LAD7 SILVER COIN14 FORTHEFUNOFIT1 AMBASSADOR LAD3 MISTER ZAO

Code:

Sub eCaptureVenue2()
 
On Error Resume Next
Application.DisplayAlerts = False
Application.ScreenUpdating = False
 
Dim shn As String
shn = Sheets("RacePage").Range("I6").Value
'shn = Sheets("RacePage").Range("L6").Value & "-Details"
ThisWorkbook.Worksheets(shn).Activate
ThisWorkbook.Worksheets(shn).Range("c65536").End(xlUp).Offset(2, 0).Offset(0,-2) = Sheets("RacePage").Range("L6") & " " & Sheets("RacePage").Range("P6")
 
ThisWorkbook.Worksheets("Racepage").Range("AC18") = "Personal"
ThisWorkbook.Worksheets("Racepage").Range("y14:y21").Copy
ThisWorkbook.Worksheets(shn).Select
ThisWorkbook.Worksheets(shn).Range("A65536").End(xlUp).Offset(0, 1).PasteSpecial Paste:=xlValues
ThisWorkbook.Worksheets("Racepage").Range("AC18") = "SkyForm"
ThisWorkbook.Worksheets("Racepage").Range("y14:y21").Copy
ThisWorkbook.Worksheets(shn).Select
ThisWorkbook.Worksheets(shn).Range("A65536").End(xlUp).Offset(0, 2).PasteSpecial Paste:=xlValues
ThisWorkbook.Worksheets("Racepage").Select
ThisWorkbook.Worksheets("Racepage").Range("x25:ac33").Copy
ThisWorkbook.Worksheets(shn).Select
ThisWorkbook.Worksheets(shn).Range("A65536").End(xlUp).Offset(0, 3).PasteSpecial Paste:=xlValues
ThisWorkbook.Worksheets("Racepage").Select
'ThisWorkbook.Worksheets("Racepage").Range("c39:r42").Copy
'ThisWorkbook.Worksheets(shn).Select
'ThisWorkbook.Worksheets(shn).Range("A65536").End(xlUp).Offset(0, 30).PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'ThisWorkbook.Worksheets("Racepage").Select
 
Dim skyuname As Variant
Dim sr As Variant
Dim bf As Variant
Dim reform As Variant
Dim dist As Variant
Dim cl As Variant
Dim trating As Variant
Dim iwet As Variant
Dim uni As Variant
Dim boa As Variant
Dim z As Byte
 
skyuname = ThisWorkbook.Worksheets("Racepage").Range("b39:b46")
sr = ThisWorkbook.Worksheets("Racepage").Range("c39:c42")
bf = ThisWorkbook.Worksheets("Racepage").Range("f39:f42")
reform = ThisWorkbook.Worksheets("Racepage").Range("i39:i42")
dist = ThisWorkbook.Worksheets("Racepage").Range("k39:k42")
cl = ThisWorkbook.Worksheets("Racepage").Range("n39:n42")
trating = ThisWorkbook.Worksheets("Racepage").Range("p39:p42")
iwet = ThisWorkbook.Worksheets("Racepage").Range("r39:r42")
uni = ThisWorkbook.Worksheets("Racepage").Range("u39:u43")
boa = ThisWorkbook.Worksheets("Racepage").Range("ab39:ab42")
)
 
ThisWorkbook.Worksheets(shn).Select
For z = 1 To 5
With ThisWorkbook.Worksheets(shn)
.Range("A65536").End(xlUp).Offset(0, 26).Offset(z - 1, 0) = skyuname(z,1)
.Range("A65536").End(xlUp).Offset(0, 9).Offset(z - 1, 0) = sr(z, 1)
.Range("A65536").End(xlUp).Offset(0, 10).Offset(z - 1, 0) = bf(z, 1)
.Range("A65536").End(xlUp).Offset(0, 11).Offset(z - 1, 0) = reform(z, 1)
.Range("A65536").End(xlUp).Offset(0, 12).Offset(z - 1, 0) = dist(z, 1)
.Range("A65536").End(xlUp).Offset(0, 13).Offset(z - 1, 0) = cl(z, 1)
.Range("A65536").End(xlUp).Offset(0, 14).Offset(z - 1, 0) = trating(z, 1)
.Range("A65536").End(xlUp).Offset(0, 15).Offset(z - 1, 0) = iwet(z, 1)
.Range("A65536").End(xlUp).Offset(0, 16).Offset(z - 1, 0) = uni(z, 1)
.Range("A65536").End(xlUp).Offset(0, 17).Offset(z - 1, 0) = boa(z, 1)
.Range("A65536").End(xlUp).Offset(0, 26).Offset(z - 1, 0) = skyuname(z,1)
.Range("A" & l_colA_row + 1 & ":A" & l_colA_row + 7).NumberFormat = "FormatOriginalFormatting"
End With
 
Next z
 
With ThisWorkbook.Worksheets(shn)
l_colA_row = .Range("A" & .Rows.Count).End(xlUp).Row + 1
.Range("A" & l_colA_row) = Sheets("RacePage").Range("F6")
.Range("A" & l_colA_row + 1) = Sheets("RacePage").Range("G6")
.Range("A" & l_colA_row + 2) = Sheets("RacePage").Range("U6")
.Range("A" & l_colA_row + 3) = Sheets("RacePage").Range("Z6")
.Range("A" & l_colA_row + 4) = Sheets("RacePage").Range("S6")
.Range("A" & l_colA_row + 5).NumberFormat = "h:mm AM/PM"
 
 
.Range("A" & l_colA_row + 5) = WorksheetFunction.CountIf(Sheets("Personal").Range("B2:B25"), ">0")
.Range("A" & l_colA_row + 1 & ":A" & l_colA_row + 7).NumberFormat = "General"
 
End With
 
On Error GoTo 0
 
'If ThisWorkbook.Sheets("RacePage").Range("AC22").Value = "Automatic" And ThisWorkbook.Sheets("RacePage").Range("P6").Value < ThisWorkbook.Sheets("RacePage").Range("AB4").Value Then
' ThisWorkbook.Sheets("RacePage").Range("P6").Value = Range("P6").Value + 1
'Racelist
'End If
'Call eFormat
End Sub

----------------------------------------------------------------------

Code:

Sub eFormat()
Dim shn As String
 
shn = Sheets("RacePage").Range("I6").Value
'shn = Sheets("RacePage").Range("L6").Value & "-Details"
ThisWorkbook.Worksheets(shn).Select
ThisWorkbook.Worksheets(shn).Range(Range("A65536").End(xlUp).Offset(4, 0), Range("X1")).Select
With Selection
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
End With
ThisWorkbook.Worksheets(shn).Range("A1:Z1").EntireColumn.AutoFit
With ThisWorkbook.Worksheets(shn).Range("A:Z")
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
End With
ThisWorkbook.Worksheets(shn).Range("A:Z").EntireColumn.AutoFit
With ThisWorkbook.Worksheets(shn).Range("J:R")
Columns("J:R").Select
Selection.NumberFormat = "General"
End With
ThisWorkbook.Worksheets(shn).Range("A1").Activate
'MsgBox "Task Completed", vbInformation, "Info:"
End Sub

Pecoflyer · #2 09-06-2016, 01:58 AM

Hi

please wrap code with code tags. I have done it for you this time. Thank you

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Rich Text Content Contol retain Style Setting when whole document is changed	ciresuark	Word	1	02-22-2016 06:25 PM
Changing the font colour in all text boxes	marqives	Word VBA	1	11-25-2014 06:05 PM
Text Box Back Colour problem	kirkm	Word	1	08-16-2014 06:27 AM
How to copy linked Excel and Word files and retain links	ashleynpeters1	Word	1	05-30-2013 02:25 PM
changing the colour of text box highlight in PowerPoint v.x	miki	PowerPoint	1	11-16-2010 02:06 AM