Hi,
Bit of elongated code here but after hours of trying i have nearly given up!, This code takes a file, copies some stuff to a new file and the saves it in a directory (or so i'd hope).
It keeps falling over on the:
bk.SaveAs Filename:=Range("E3").Select
line at the end.
Any help would be superb.
thanks
James
Sub ExtractTrustData()
Sheets("DNA").Select
Sheets("DNA").Range("C3:C396").Select
Dim TrustRef As Range
For Each TrustRef In Selection
TrustRef.Copy
Workbooks.Add 'add new workbook to copy data into
Dim bk As Workbook
Dim FlFormat As String
Dim SaveNameAs As String
Range("D2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False 'paste trust reference
Range("D3").Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(R2C4,'[SMS Trust Data.xls]DNA'!R3C3:R396C37,ROW()-1,0)" 'vlookup trust ref and get other data
Range("E3").Select
ActiveCell.FormulaR1C1 = _
"=""C:\JamesRyan"" & R3C4 " 'insert filename to save as
Selection.Font.ColorIndex = 2
Range("D3").Select
Selection.Copy
Range("D4:D36").Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False 'copy lookup formula downwards
Range("A1").Select
Application.CutCopyMode = False
ActiveWindow.ActivateNext
Sheets("Info").Select
Range("A1:B35").Select 'copy in headings and titles
Selection.Copy
ActiveWindow.ActivateNext
Range("B2").Select
ActiveSheet.Paste
Columns("A:D").Select
With Selection.Font 'change all fonts to arial
.Name = "Arial"
.ColorIndex = xlAutomatic
End With
With Selection.Font 'change all font sizes to 8
.Name = "Arial"
.Size = 8
.ColorIndex = xlAutomatic
End With
Columns("D:D").Select
Selection.Style = "Comma"
Selection.NumberFormat = "_-* #,##0_-;-* #,##0_-;_-* ""-""??_-;_-@_-" 'put all numbers in accounting style
Range("B2:D4,B5:D8,B9:D12,B13:D16,B17:D20,B21:D24,B25:D28,B29:D32,B33:D36"). _
Select
Range("B33").Activate
Selection.Borders(xlDiagonalDown).LineStyle = xlNone 'put main borders on cells
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone 'put borders on top cells
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("B5:D8,B21:D24").Select
Range("B21").Activate
With Selection.Interior 'start colouring cells
.ColorIndex = 35
.Pattern = xlSolid
End With
Range("B9:D12,B25:D28").Select
Range("B25").Activate
With Selection.Interior
.ColorIndex = 22
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
Range("B13:D16,B29:D32").Select
Range("B29").Activate
With Selection.Interior
.ColorIndex = 37
.Pattern = xlSolid
End With
Range("B17:D20,B33:D36").Select
Range("B33").Activate
With Selection.Interior
.ColorIndex = 36
.Pattern = xlSolid
End With
Range("B2:D4").Select
With Selection.Interior
.ColorIndex = 15
.Pattern = xlSolid
End With 'end colouring cells
Selection.Font.Bold = True
Columns("B:D").Select
Columns("B:D").EntireColumn.AutoFit 'autofit all columns
Range("B5:B36").Select 'start bordering titles
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With 'end bordering titles
Range("C5:D8,C9:D12,C13:D16,C17:D20,C21:D24,C25:D28,C29:D32,C33:D36").Select 'start bordering inside lines
Range("C33").Activate
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With 'end bordering inside lines
ActiveWindow.ActivateNext 'start copying table of information required
Sheets("Info").Select
Range("A37:B41").Select
Selection.Copy
ActiveWindow.ActivateNext
Range("B38").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone 'end copying of table of information required
Columns("F:F").Select 'hide other columns and rows
Range(Selection, Selection.End(xlToRight)).Select
Selection.ColumnWidth = 0
Rows("44:44").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.RowHeight = 0
SaveNameAs = E5 'name cell for filename
FlFormat = ActiveWorkbook.FileFormat
bk.SaveAs Filename:=Range("E3").Select
bk.Saved = True
bk.Close
Next
End Sub
Bookmarks