Excel VBA kopírování hodnot nefunkční kopírování nul

0
0

Dobrý den, mam makro ,které hledá a překopírová data na určité místo. Ale problém spočívá v tom, že když se v dané hodnotě 0 na začátku, tak to tu 0 nezkopíruje a vezme to bez ní (00H52 ale excel mi zkopíruje pouze H52). Dolu házím celé makro. Kdyby někdo věděl moc děkuji.

Sub GetFileCopyData()
Dim Fname As String
Dim SrcWbk As Workbook
Dim DestWbk As Workbook

Set DestWbk = ThisWorkbook

Fname = Application.GetOpenFilename(FileFilter:=Clear, Title:="Select a File")
If Fname = "False" Then Exit Sub
Set SrcWbk = Workbooks.Open(Fname)

SrcWbk.Sheets(1).Name = "List1"

SrcWbk.Sheets("List1").Range("A42:E75").Copy DestWbk.Sheets("match").Range("B:F")

SrcWbk.Close False

Sheets("match").Select
Columns("B:F").Select
Selection.Hyperlinks.Delete
Selection.UnMerge
Columns("E:E").Select
Selection.Cut Destination:=Columns("G:G")
Columns("F:G").Select
Selection.Cut Destination:=Columns("E:F")

'
Range("B1:G319").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection
.HorizontalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlLTR
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlLTR
.MergeCells = False
End With
With Selection.Font
.Name = "Arial"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Columns("B:B").Select
Selection.Font.Bold = False
Selection.Font.Bold = True

Range("B1:G238").Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.599993896298105
.PatternTintAndShade = 0
End With
Range("H15").Select
Sheets("RSV").Select
End Sub

Marked as spam
Odeslal Anonymous
Otázka položena 17.8.2019 7:36
26 views
0
Private answer

http://wall.cz/index.php?m=topic&id=43981

Marked as spam
Odeslal Anonymous
Odpověděl 18.8.2019 7:54

Odešlete svou odpověď

Attach YouTube/Vimeo clip putting the URL in brackets: [https://youtu.be/Zkdf3kaso]