Nhờ xem và sửa code vẽ đồ thị và xuất ra autocad (1 người xem)

[khoavu87]

-hiện giờ mình đang muốn từ số liệu mình vừa copy sang sheet "độtthi"sẽ vẽ đc biểu đồ nhưng mình làm mãi không ra.
-thứ hai mình muốn dùng cái dữ liệu vừa vẽ biểu đồ đó dùng nó ;làm tọa độ để vẽ ra các dường gấp khúc ra cad,tức là phải làm thủ tục liên kết excel với cad.
-các anh ai có thể giúp em với.cảm ơn các anh.
- dưới đây là bài của em.các sư huynh coppy về và cho chạy thử nhé./
Sub hieuchinhsolieuthuyvan_khoavu_txt()

'***doi ten worksheets
Worksheets("sheet1").Name = "tinhthuyvan"
Worksheets("sheet2").Name = "bangtra"
Worksheets("sheet3").Name = "dothi"
Worksheets("tinhthuyvan").Range("E2:G13").BorderAround _
LineStyle:=xlDashDot, ColorIndex:=3, Weight:=xlThick
'***doi mau vao vung du lieu minh vua lua chon
Dim mycolumns As Range
For Each mycolumns In Range("E2:G13").Columns
'*** doi mau
mycolumns.Interior.Color = RGB(0, 255, 0)
Next mycolumns
'***hien thi noi dung Comment
Dim mycommen As Comment
For Each mycommen In Worksheets("tinhthuyvan").Comments
MsgBox mycommen.Text
Next mycommen
Range("G1").AddComment "vu tran khoa:luu luong khao sat duoc theo cac nam"

'***lay tep tin chua file khoavu.txt
'***ten file can doc du lieu
Dim tenfile As String
tenfile = InputBox("nhap ten file can doc---Khoavu")
Dim filt As String
Dim filterindex As Integer
Dim title As String
Dim filename As String
Dim a As String
Dim Temp
Dim Row As Long
Row = 0
'*** gan bo loc tep
filt = "text files (*.txt),*.txt," & "comma separated files (*.csv), *.csv," & "all files (*.*),*.*"
'***hien thi cac tep *.txt la mac dinh
filterindex = 1
'***gan tieu de cho hop thu thoai
title = "chon tep khoavu"
'***lay ten tep
filename = Application.GetOpenFilename(filefilter:=filt, filterindex:=filterindex, title:=title)
'***thoat neu nhan nut cancel
If filename = "false" Then
MsgBox "khong tep tin nao duoc chon"
Exit Sub
End If
'***hien thi ten tep day du
MsgBox "ban vua chon tep: " & filename
Open filename For Input As 1
Do While Not (EOF(1))
Line Input #1, a
Temp = Split(a, ",")
Row = Row + 1
ThisWorkbook.Worksheets("tinhthuyvan").Cells(Row, 5).Value = Temp(0)
ThisWorkbook.Worksheets("tinhthuyvan").Cells(Row, 6).Value = Temp(1)
ThisWorkbook.Worksheets("tinhthuyvan").Cells(Row, 7).Value = Temp(2)
Loop
Close 1
chonlai1:

' Dim r As Range
' tinh gia tri trung binh Q
'Set r = Application.InputBox("Gia tri trung binh cua Q ", Type:=8)
'Qtb = Application.WorksheetFunction.Average(r)
'r.Cells(r.Rows.Count + 1, 1) = Qtb
'ThisWorkbook.ActiveSheet.Range("A15").Value = " Qtb ="
'***thiet lap va xu ly loi,bo qua tat ca cac loi va cau lenh tiep theo
On Error Resume Next
'***lua chon cot tinh luu luong
Dim cot As Range
'***Lua chon thu tu giam dan cua so lieu thuy van
Set cot = Application.InputBox(" thu tu giam dan cua Qi ", Type:=8)
cot.Sort cot.Columns(1).Cells, xlDescending
Set cot = Application.InputBox("Lua chon cot tinh luu luong thuy van Qi ", Type:=8)
If Err.Number <> 0 Then
MsgBox "Lua chon co loi :" & Err.Description, vbCritical, " Thong bao loi cho nguoi dung "
GoTo chonlai1
End If
cot.Sort cot.Columns(1).Cells, xlAscending
'***tinh luu luong trung binh
Dim Q As Double
Q = Application.WorksheetFunction.Average(cot)
'***dung de gan gia tri Q tinh duoc cua moi o vao o duoi cung cua cot
cot.Cells(cot.Rows.Count + 1, 1) = Q
cot.Cells(cot.Rows.Count + 1, cot.Columns.Count - 1) = "Qtb = "
cot.Cells(cot.Rows.Count + 1, cot.Columns.Count - 1).Font.Color = RGB(255, 0, 0)

Dim mycomment As Comment
For Each mycomment In Worksheets("tinhthuyvan").Comments
MsgBox mycomment.Text
Next mycomment
Range("G14").AddComment "vu tran khoa:luu luong trung binh vua tinh duoc"

Dim cot1 As Range
Dim i As Integer
Dim j As Integer
Dim tg As Double
Dim tg1 As Double
Dim tg2 As Double
Dim Tong1 As Double
Dim Tong2 As Double
ThisWorkbook.Worksheets("tinhthuyvan").Range("I1") = "Ki"
ThisWorkbook.Worksheets("tinhthuyvan").Range("J1") = "(Ki-1)^2"
ThisWorkbook.Worksheets("tinhthuyvan").Range("K1") = "(Ki-1)^3"
For Each cot1 In cot
i = i + 1
tg = cot1.Value / Q
tg1 = (tg - 1) ^ 2
tg2 = (tg - 1) ^ 3
ThisWorkbook.Worksheets("tinhthuyvan").Range("I2").Resize(i, 1).Cells(i, 1).Value = tg
ThisWorkbook.Worksheets("tinhthuyvan").Range("J2").Resize(i, 1).Cells(i, 1).Value = tg1
ThisWorkbook.Worksheets("tinhthuyvan").Range("K2").Resize(i, 1).Cells(i, 1).Value = tg2
Tong1 = Tong1 + tg1
Tong2 = Tong2 + tg2
ThisWorkbook.Worksheets("tinhthuyvan").Range("I2").Resize(i + 1, 1).Cells(i + 1, 1) = "Tong="
ThisWorkbook.Worksheets("tinhthuyvan").Range("J2").Resize(i + 1, 1).Cells(i + 1, 1).Value = Tong1
ThisWorkbook.Worksheets("tinhthuyvan").Range("K2").Resize(i + 1, 1).Cells(i + 1, 1).Value = Tong2
Next cot1
'TINH Cs,Cv
Dim cs As Double
Dim cv As Double
cs = Round((Tong1 / (i - 1)) ^ (0.5), 1)
cv = Round(Tong2 / ((i - 1) * cs), 1)
ThisWorkbook.Worksheets("tinhthuyvan").Range("I2").Resize(i + 2, 1).Cells(i + 2, 1) = "Cs="
ThisWorkbook.Worksheets("tinhthuyvan").Range("J2").Resize(i + 2, 1).Cells(i + 2, 1).Value = cs
ThisWorkbook.Worksheets("tinhthuyvan").Range("I2").Resize(i + 3, 1).Cells(i + 3, 1) = "Cv="
ThisWorkbook.Worksheets("tinhthuyvan").Range("J2").Resize(i + 3, 1).Cells(i + 3, 1).Value = cv
'***Chuyen doi vung du lieu trong Excel ra dang file text***
'***Change dimension to use late binding ***
Dim FSO As Object 'FSO As Scripting.FileSystemObject
Dim TextStr As Object 'TextStr As Scripting.TextStream
Dim Rng As Range
'***tao doi tuong su dung de tao ra mot FileSystemObject ***
Set FSO = CreateObject("Scripting.FileSystemObject")
'***Mo mot tap tin van ban cho appending***
'***Neu khong ton tai tap tin ta se tao ra mot tap tin moi duoi *txt ***
ForAppending = 8
Set TextStr = FSO.OpenTextFile(filename:="E:\Fileketqua.txt", _
IOMode:=ForAppending, Create:=True)
For Each Rng In Range("G1:G14")
If Rng.Value <> "" Then
TextStr.WriteLine Text:="The Value In: " & _
Rng.Address(False, False) & " is: " & Rng.Value
End If
Next Rng
For Each Rng In Range("I1:K16")
If Rng.Value <> "" Then
TextStr.WriteLine Text:="The Value In: " & _
Rng.Address(False, False) & " is: " & Rng.Value
End If
Next Rng
TextStr.Close
Set FSO = Nothing

'***************************
Dim r2 As Range
Dim hg As Integer
Dim co As Integer
' xu ly loi
chonlai2:
On Error Resume Next
Set r2 = Application.InputBox("Chon bang can tra o bangtra", Type:=8)
If Err.Number <> 0 Then
MsgBox "Co loi :" & Err.Description, vbCritical, "Thong bao loi"
GoTo chonlai2
End If

hg = r2.Rows.Count
co = r2.Columns.Coun

' ThisWorkbook.Worksheets("tinhthuyvan").Range("L3") = "P%"
ThisWorkbook.Worksheets("tinhthuyvan").Range("L4") = "Qp%"
For i = 2 To cot
ThisWorkbook.Worksheets("tinhthuyvan").Range("M3").Resize(1, i).Cells(1, i) = r2.Cells(1, i).Value
Next i

For i = 1 To hang1
If cs = r2.Cells(i, 1) Then
For j = 2 To cot1
ThisWorkbook.Worksheets("tinhthuyvan").Range("J3").Resize(1, j).Cells(1, j).Value = ((r2.Cells(i, j) * cv) + 1) * Q
Next j
End If
Next i
'***ve bieu do:
'm:so tran lu
'n:so nam bang quan trac
Dim m As Range
Dim n As Double
Dim p As Double
Dim a1 As Double
a1 = ThisWorkbook.ActiveSheet.Range("A12").Value
n = a1 + 1
For Each m In Range("G2:G13").Rows
p = (1 / 100) * Val(m) / (n + 1)
' xuat ket qua
m.Cells(m.Columns.Count, 2) = p
Next m
ThisWorkbook.ActiveSheet.Range("H1").Value = "P%"
'***coppy du lieu
Sheets("tinhthuyvan").[G1:H13].Copy: Sheets("dothi").[G1:H13].PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Dim chrt As ChartObject
Set chrt = ThisWorkbook.Worksheets("dothi").ChartObjects.Add(100, 30, 400, 250)
chrt.Name = "Bieu do"
chrt.Chart.ChartWizard ThisWorkbook.Worksheets("dothi").Range("G1:H13"), xlLine, , xlRows, 1, 1, True, "Bieu do duong tan suat", "Qi", "P%"

'***doan ma dung de dem thoi gian
startTime = Timer
For Z = 1 To 14
Cells(Z, 1) = Z
Next
EndTime = Timer
ttime = EndTime - startTime
hh = Int(ttime / 3600)
mm = Int((ttime - hh * 3600) / 60)
ss = Int(ttime - hh * 3600 - mm * 60)
ct = ttime - Int(ttime)

MsgBox "Thoi gian chay ket qua la: " & Chr(10) _
& ttime & "s" & Chr(10) _
& Format(hh, "00") & ":" & Format(mm, "00") & ":" _
& Format(ss, "00") & ":" & Format(ct * 100, "00")

End Sub

 

[khoavu87]

sao chưa có bác nào giúp mình nhỉ