|
|
#1
09-05-2016, 07:34 PM
|
|||
|
|||
Excel VBA Retain colour of text
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
Last edited by Pecoflyer; 09-06-2016 at 01:57 AM. 
|
|
#2
09-06-2016, 01:58 AM
|
||||
|
||||
|
Hi
please wrap code with code tags. I have done it for you this time. Thank you
__________________
Using O365 v2503 - Did you know you can thank someone who helped you? Click on the tiny scale in the right upper hand corner of your helper's post
|
|
|
|
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 |
Windows 7 64bit 
Office 2010 64bit
Linear Mode
