#1
|
|||
|
|||
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
|
||||
|
||||
Hi
please wrap code with code tags. I have done it for you this time. Thank you
__________________
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 |