Dùng VBA tính khoảng cách giữa các cọc

Liên hệ QC
T

tranvanhung2009

Thành viên hoạt động
Tham gia
1/3/11
Bài viết
128
Được thích
18
Xin chào các anh chị trong nhóm!
Mình cần sự giúp đỡ của mọi người tạo 1 code để tính khoảng cách các vị trí trong 1 đài cọc.
Ở trong file excell mình đính kèm có kết quả tính và sơ đồ tính.
Mong được mọi người giúp đỡ!
 

File đính kèm

  • Code tinh khoang cach cach coc trong nhom.xlsm
    36.9 KB · Đọc: 24
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Bài này chỉ cần liệt kê cặp đôi tung hoành, tức là địa chỉ mỗi cọc.
Có bảng liệt kê rồi thì chỉ việc tính khoảng cách từng cặp đôi địa chỉ.
 
Upvote 0
Em đã đã liệt kê trong ví dụ là cặp móng có 3 hàng 3 cột. Với những móng hoặc bè có nhiều cọc giải sử lên đến hàng 15 hàng 15 cột hoặc nhiều hơn thì thực sự là phức tạp.
Em cũng đã tính như bạn dùng code này để lấy tọa độ các cọc trong vùng tư B1 đến D5, sau đó dùng công thức thủ công để tính tọa độ có kết quả từ B20 đến J28
với khoảng cách cần tính ví dụ cọc 1 (11) tương tác với cọc 6 (23) có công thức Sqrt((1-2)^2+(1-3)^2)

Sub toadococ()
Dim i As Integer, j As Integer, k As Integer, m As Integer, n As Integer, a As Integer, b As Integer
m = 3 ' Hang nhom coc
n = 3 ' Cot nhom coc
'Tinh ma tran A
For i = 1 To n ' So hang phan tu trong ma tran khoang cach A
For j = 1 To n 'So cot phan tu trong ma tran khoang cach A
Cells(i + 2, j + 1) = i & j
Next j

Next i
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
tranvanhung2009 đã viết:
Thầy có thể giúp em viết 1 đoạn code về mảng tính bài toán này được không ạ. Vì em có đọc qua 1 số tài liệu về mảng thấy rất ưu việt, chỉ có điều kiến thức về ngôn ngữ lập trình không thực sự biết nhiều.
Nhấp chuột vào đây để mở rộng...
Mình không dám nói có giúp được bạn hay không, nhưng cũng thử xem. Có điều mình chưa hiểu đề bài :D. Vùng nào dữ liệu, vùng nào cần chạy ra kết quả chưa hiểu lắm. Vì nhìn code bạn đưa lên so với chỗ bạn gọi là "kết quả" nó không khớp nhau
 
Upvote 0
Nhattanktnn đã viết:
Mình không dám nói có giúp được bạn hay không, nhưng cũng thử xem. Có điều mình chưa hiểu đề bài :D. Vùng nào dữ liệu, vùng nào cần chạy ra kết quả chưa hiểu lắm. Vì nhìn code bạn đưa lên so với chỗ bạn gọi là "kết quả" nó không khớp nhau
Nhấp chuột vào đây để mở rộng...
Đề bài là mình có một móng cọc có dạng n hàng và m cột (trong ví dụ là n = 3 và m =3)
Lúc này mình có ma trận được như vùng B3 đến D5 trong file cell ( Tức là có 9 cọc với khoảng cách giữa các cọc là a, ở đây a = 1 cho dễ tính)
Bây giờ mình cần tìm 1 ma trận mà kết quả trả về ở vùng B20 đến J28. Ở trên bảng cell đính kèm mình đã làm thủ công theo công thức định lí pitago
Ví dụ lấy cọc 1 là cọc cần xét đến khoảng cách cách cọc còn lại sẽ trả về giá trị ở hàng 20, với công thức tính như sau:
Khoảng cách từ cọc 1 (hàng 1 cột 1) đến cọc 1(hàng 1 cột 1) =sqrt((hàng 1 - hàng 1)^2+(cột 1 - cột 1)^2) = 0 (Vì khoảng cách từ nó đến chính nó trùng nhau nên bằng 0) ta được giá trị ở ô B20
Khoảng cách từ cọc 1 (hàng 1 cột 1) đến cọc 2(hàng 1 cột 2) =sqrt((hàng 1 - hàng 1)^2+(cột 1 - cột 2)^2) = 1 ta được giá trị ở ô C20
....
Tương tự tính hết đến cọc thứ 9 . Ta sẽ được kết quả toàn bộ của cọc 1 ảnh hưởng đến 8 cọc còn lại, kết quả ở dòng 20
Sau đó ta lại tiếp tục lấy cọc thứ 2 để tính khoảng cách cho các vị trí còn lại , kết quả thu được ở dòng số 21
Tương tự ta tính đến cọc thứ 3 rồi đền cọc thứ 9

Kết quả mình cần là bảng giá trị từ B20 đến J28
 
Upvote 0
Nhattanktnn đã viết:
Mình không dám nói có giúp được bạn hay không, nhưng cũng thử xem. Có điều mình chưa hiểu đề bài :D. Vùng nào dữ liệu, vùng nào cần chạy ra kết quả chưa hiểu lắm. Vì nhìn code bạn đưa lên so với chỗ bạn gọi là "kết quả" nó không khớp nhau
Nhấp chuột vào đây để mở rộng...
Code chả ăn nhằm gì hết bởi vì thớt không rành môn hình học lắm.
Bài này chỉ là một mảng vuông, có cạnh m*n, với m là số cọc theo dòng và n là số cọc theo cột.
Mảng có đường chéo là zero và các trị còn lại đối xứng qua đường chéo.
Nếu bạn chịu khó vẽ ra giấy thì sẽ tìm được công thức liên hệ giữa chỉ số dòng và cột mảng với vị trí cọc.
Có công thức liên hệ rồi thì con tính rất đơn giản.

Cái khó là vòng lặp duyệt qua mảng. Đương nhiên mảng 2 chiều nên phải lồng 1 vòng lặp trong vòng lặp. Lồng thế nào cho khéo?
Khuya rồi tôi hơi lười. Bạn thử xem. Gợi ý: nhớ từ "đối xứng" tôi nêu ở trên.

Chú: trong ví dụ của thớt thì cọc có 3 hàng ngang và 3 hàng dọc cho nên mảng kết quả có mỗi chiều là 3*3 = 9 (không kể dòng và cột ghi toạ độ).
 
Upvote 0
Code đủ xài. Lưu ý đây là giải thuật lười biếng:
1. con toán tính chiều x, y (tôi nghĩ) có thể tính theo cách luỹ kế, hiệu quả hơn. Nhưng tôi chưa tìm ra quy luật.
2. nhiều trị số bị được tính lặp lại. Nhìn hình thì thấy rõ có thể dùng phép áp dịch theo đường chéo nào đó để biết phần tử nào tương đường phần tử nào. Nhưng tôi lười tính quy luật. Phép áp hiển nhiên nhất là dùng đường chéo chính thì tôi đã làm rồi.
(chịu khó đọc comments tiếng Anh. Bài này phức tạp, tôi vừa code vừa chú nên bắt buộc không thể dùng tiếng Việt)

Mã: 
Sub BMatrix()
' builds a matrix NxN depicting distances between individual grid posts/pillars
Const SODNG = 3
Const SOCOT = 4
Dim a() As Variant, aSize As Long ' resultant array and its size
aSize = SODNG * SOCOT
ReDim a(0 To aSize, 0 To aSize)
' the matrix starts at 1, the row and column 0 are for grid positions
Dim i As Long, i2 As Long ' vars to traverse matrix, columnwise
Dim x As Long, y As Long ' corresponding coordinates of each element
For i = 1 To aSize
    x = XCoord(i, SOCOT)
    y = YCoord(i, SOCOT)
    a(0, i) = CStr(x) & " " & CStr(y) ' the title (grid coordinates)
    a(i, 0) = a(0, i)
    a(i, i) = 0
    For i2 = i - 1 To 1 Step -1 ' go backward from the diagonal
        a(i, i2) = Sqr((x - XCoord(i2, SOCOT)) ^ 2 + (y - YCoord(i2, SOCOT)) ^ 2)
        a(i2, i) = a(i, i2) ' the matrix is symmetrical
    Next i2
    x0 = x
    y0 = y
Next i
Range("a1").Resize(aSize + 1, aSize + 1).Value = a
End Sub

Function XCoord(ByVal pos As Long, ByVal mxCol As Long)
' returns the row number of corresponding grid point
XCoord = ((pos - 1) \ mxCol) + 1
End Function

Function YCoord(ByVal pos As Long, ByVal mxCol As Long)
' returns the column number of corresponding grid point
YCoord = ((pos - 1) Mod mxCol) + 1
End Function
[/coce]
 
Upvote 0
VetMini đã viết:
Code đủ xài. Lưu ý đây là giải thuật lười biếng:
1. con toán tính chiều x, y (tôi nghĩ) có thể tính theo cách luỹ kế, hiệu quả hơn. Nhưng tôi chưa tìm ra quy luật.
2. nhiều trị số bị được tính lặp lại. Nhìn hình thì thấy rõ có thể dùng phép áp dịch theo đường chéo nào đó để biết phần tử nào tương đường phần tử nào. Nhưng tôi lười tính quy luật. Phép áp hiển nhiên nhất là dùng đường chéo chính thì tôi đã làm rồi.
(chịu khó đọc comments tiếng Anh. Bài này phức tạp, tôi vừa code vừa chú nên bắt buộc không thể dùng tiếng Việt)

Mã: 
Sub BMatrix()
' builds a matrix NxN depicting distances between individual grid posts/pillars
Const SODNG = 3
Const SOCOT = 4
Dim a() As Variant, aSize As Long ' resultant array and its size
aSize = SODNG * SOCOT
ReDim a(0 To aSize, 0 To aSize)
' the matrix starts at 1, the row and column 0 are for grid positions
Dim i As Long, i2 As Long ' vars to traverse matrix, columnwise
Dim x As Long, y As Long ' corresponding coordinates of each element
For i = 1 To aSize
    x = XCoord(i, SOCOT)
    y = YCoord(i, SOCOT)
    a(0, i) = CStr(x) & " " & CStr(y) ' the title (grid coordinates)
    a(i, 0) = a(0, i)
    a(i, i) = 0
    For i2 = i - 1 To 1 Step -1 ' go backward from the diagonal
        a(i, i2) = Sqr((x - XCoord(i2, SOCOT)) ^ 2 + (y - YCoord(i2, SOCOT)) ^ 2)
        a(i2, i) = a(i, i2) ' the matrix is symmetrical
    Next i2
    x0 = x
    y0 = y
Next i
Range("a1").Resize(aSize + 1, aSize + 1).Value = a
End Sub

Function XCoord(ByVal pos As Long, ByVal mxCol As Long)
' returns the row number of corresponding grid point
XCoord = ((pos - 1) \ mxCol) + 1
End Function

Function YCoord(ByVal pos As Long, ByVal mxCol As Long)
' returns the column number of corresponding grid point
YCoord = ((pos - 1) Mod mxCol) + 1
End Function
[/coce]
Nhấp chuột vào đây để mở rộng...
Em cám ơn Thầy nhiều, như này cũng đã đủ để người nông dân không phải đi cày rồi thầy ạ.
Không biết cám ơn thầy thế nào cho đủ, em chúc Thầy sức khỏe!
 
Upvote 0
tranvanhung2009 đã viết:
Em cám ơn Thầy nhiều, như này cũng đã đủ để người nông dân không phải đi cày rồi thầy ạ.
Không biết cám ơn thầy thế nào cho đủ, em chúc Thầy sức khỏe!
Nhấp chuột vào đây để mở rộng...
Thắc mắc: người nông dân không phải đi cày thì làm gì bi giờ?
Nào giờ tôi cứ ngỡ công nghệ cốt nâng cao năng suất, giúp người ta ổn định đời sống. Té ra mục đích của công nghệ là giảm công việc, giúp người ta có nhiều thì giờ nhàn nhã sao?
 
Upvote 0
VetMini đã viết:
Thắc mắc: người nông dân không phải đi cày thì làm gì bi giờ?
Nào giờ tôi cứ ngỡ công nghệ cốt nâng cao năng suất, giúp người ta ổn định đời sống. Té ra mục đích của công nghệ là giảm công việc, giúp người ta có nhiều thì giờ nhàn nhã sao?
Nhấp chuột vào đây để mở rộng...
Thì do "nâng cao năng suất" nên làm 1 giờ bằng trước kia làm 8 giờ, đủ sở hụi, nên 7 giờ "nhàn nhã". Chứ làm thêm giờ thứ 2 trở về sau xã hội hay ai đó được lợi chứ cá nhân chả được gì.
 
Upvote 0
ptm0412 đã viết:
Thì do "nâng cao năng suất" nên làm 1 giờ bằng trước kia làm 8 giờ, đủ sở hụi, nên 7 giờ "nhàn nhã". Chứ làm thêm giờ thứ 2 trở về sau xã hội hay ai đó được lợi chứ cá nhân chả được gì.
Nhấp chuột vào đây để mở rộng...
Chính thức câu hỏi của tôi nằm chỗ đó:
- theo cái nhìn của người cung cấp lao động thì công nghệ giúp cho giảm lao động (*1)
- theo cái nhìn của bên cung cấp công nghệ thì công nghệ giúp tăng sản lượng (*2)

(*1) theo lý thuyết kinh tế thì "giảm lao động" không đúng chỗ sẽ làm giảm nhu cầu lao động. Mà theo luật cung cầu thì số cầu giảm sẽ làm khó cho bên cung. Nói cách khác là sẽ xảy ra tình trạng tụt giá lao động vfa thất nghiệp.

(*2) theo lý thuyết tư bản thì chỗ tăng sản lượng ấy thuọc về chủ đầu tư hay người lao động? Câu trả lời tuỳ theo bạn nằm trong trường phái tư bản cổ điển hay đổi mới.

Chú: nếu người nông dân làm chủ ruộng thì có cái rô bô gì đó nó cày giùm là khoẻ.
nhưng nếu người nông dân chỉ cày mướn thì cái rô bô gì đó nó làm người này thất nghiệp.
 
Upvote 0
VetMini đã viết:
Chính thức câu hỏi của tôi nằm chỗ đó:
Nhấp chuột vào đây để mở rộng...
Thật ra chủ đề tài phát biểu không phải là do suy nghĩ tiêu cực như tôi nói, có lẽ chỉ là mừng quá do công việc được giảm tải mà thôi. Có điều cách dùng chữ (nông dân không phải đi cày) là không hay lắm. Nên dùng "nông dân đi cày đỡ nhọc"
 
Upvote 0
VetMini đã viết:
Thắc mắc: người nông dân không phải đi cày thì làm gì bi giờ?
Nào giờ tôi cứ ngỡ công nghệ cốt nâng cao năng suất, giúp người ta ổn định đời sống. Té ra mục đích của công nghệ là giảm công việc, giúp người ta có nhiều thì giờ nhàn nhã sao?
Nhấp chuột vào đây để mở rộng...

ý em làm không phải làm thủ công đỡ mỏi mắt đấy thầy ạ!, Chứ việc thì vẫn phải làm, còn nhiều bài toán phức tạp cần phải dùng đến công nghệ, e cám ơn thầy nhiều lắm a.
Hôm trước em còn phải ngồi tính cho từng nhóm 4 cọc, 6 cọc, 9 cọc , 16 cọc. Ngồi máy tính nhiều hoa hết cả mắt. Nhờ có code này của thầy giờ em mạnh dạn tính đến cả một ruộng cọc chứ không phải một nhóm cọc nữa Thầy ạ.
 
Upvote 0
tranvanhung2009 đã viết:
Xin chào các anh chị trong nhóm!
Mình cần sự giúp đỡ của mọi người tạo 1 code để tính khoảng cách các vị trí trong 1 đài cọc.
Ở trong file excell mình đính kèm có kết quả tính và sơ đồ tính.
Mong được mọi người giúp đỡ!
Nhấp chuột vào đây để mở rộng...
Thử cách khác
Mã: 
Sub XYZ()
  Dim Arr(), N&, i&, j&, k&, q&
  Const sRow = 3 'So Dong
  Const sCol = 4 'So Cot
 
  N = sRow * sCol 'So coc
  ReDim Arr(0 To N, 0 To N + 2)
  For i = 1 To sRow
    For j = 1 To sCol
      k = k + 1 'Thu tu dong và cot
      Arr(k, 0) = i & " " & j 'Tieu de dong la Vi tri Coc
      Arr(0, k) = Arr(k, 0) 'Tieu de cot la Vi tri Coc
      Arr(k, N + 1) = i 'Vitri Coc theo dong
      Arr(k, N + 2) = j 'Vitri Coc theo  cot
      Arr(k, k) = 0 ' Duong cheo
      For q = 1 To k - 1
        Arr(q, k) = Sqr((Arr(q, N + 1) - i) ^ 2 + (Arr(q, N + 2) - j) ^ 2)
        Arr(k, q) = Arr(q, k)
      Next q
    Next j
  Next i
  Range("A2").CurrentRegion.ClearContents
  Range("A1").Resize(N + 1, N + 1).Value = Arr
End Sub
 
Upvote 0
Mình viết thành Function như sau:
Mã: 
Function MangKhoangCachCoc(iSoHang As Long, iSoCot As Long, iKhoangCachDonVi As Double)
  Dim x&, y&, xy&
  xy = iSoHang * iSoCot
  ReDim aX(1 To xy) 'Mang aX chua toa do Cot cua coc
  ReDim aY(1 To xy) 'Mang aY chua toa do Hang cua coc
  ReDim aXY(0 To xy, 0 To xy) ' Mang aXY chua khoang cach giua cac coc
 
  'Gan toa do coc
  xy = 0
  For y = 1 To iSoHang
    For x = 1 To iSoCot
      xy = xy + 1
      aX(xy) = x
      aY(xy) = y
    Next x
  Next y
 
  'Tinh khoang cach cac coc
  For x = 1 To xy
    aXY(x, 0) = "C_" & aY(x) & "_" & aX(x) 'Gan vi tri Coc
    aXY(0, x) = aXY(x, 0) 'Gan vi tri Coc
    aXY(x, x) = 0 'Duong cheo = 0
    For y = x + 1 To xy
      aXY(x, y) = Sqr((aX(x) - aX(y)) ^ 2 + (aY(x) - aY(y)) ^ 2) * iKhoangCachDonVi
      aXY(y, x) = aXY(x, y)
    Next y
  Next x
    
  MangKhoangCachCoc = aXY
End Function

Khi sử dụng thì gọi Function
Mã: 
Sub Test()
  Dim aXY
  aXY = MangKhoangCachCoc(4, 4, 1.5)
  Sheet1.Range("A2").CurrentRegion.ClearContents
  Sheet1.Range("A1").Resize(UBound(aXY, 1) + 1, UBound(aXY, 2) + 1) = aXY
End Sub
 
Upvote 0
tranvanhung2009 đã viết:
Xin chào các anh chị trong nhóm!
Mình cần sự giúp đỡ của mọi người tạo 1 code để tính khoảng cách các vị trí trong 1 đài cọc.
Ở trong file excell mình đính kèm có kết quả tính và sơ đồ tính.
Mong được mọi người giúp đỡ!
Nhấp chuột vào đây để mở rộng...
Bài nầy dể nhất là dùng công thức dựa trên các hàm Excel
 
Upvote 0
Mình viết lại như vậy để giảm số lần thực hiện hàm Sqr, khi số Hàng và Cột lớn thì sẽ thấy sự khác biệt.
Mã: 
Function MangKhoangCachCoc2(iSoHang As Long, iSoCot As Long, iKhoangCachDonVi As Double)
  Dim x&, y&, xy&
  xy = iSoHang * iSoCot
  ReDim aX(1 To xy)
  ReDim aY(1 To xy)
  ReDim aXY1(0 To iSoHang - 1, 0 To iSoCot - 1)
  ReDim aXY2(0 To xy, 0 To xy)
 
  xy = 0
  For y = 1 To iSoHang
    For x = 1 To iSoCot
      xy = xy + 1
      aX(xy) = x 'Gan toa do X
      aY(xy) = y 'Gan toa do Y
      aXY1(y - 1, x - 1) = Sqr((y - 1) ^ 2 + (x - 1) ^ 2) * iKhoangCachDonVi 'Gan khoang cach
    Next x
  Next y
 
  For x = 1 To xy
    aXY2(x, 0) = "C_" & aY(x) & "_" & aX(x) 'Gan vi tri Coc
    aXY2(0, x) = aXY2(x, 0) 'Gan vi tri Coc
    For y = 1 To xy
      aXY2(x, y) = aXY1(Abs(aY(x) - aY(y)), Abs(aX(x) - aX(y))) 'Gan khoang cach
    Next y
  Next x
    
  MangKhoangCachCoc2 = aXY2
End Function
 
Upvote 0
Ngô Hải Đăng đã viết:
Mình viết lại như vậy để giảm số lần thực hiện hàm Sqr, khi số Hàng và Cột lớn thì sẽ thấy sự khác biệt.
...
Nhấp chuột vào đây để mở rộng...
Dùng mảng chứa kết quả đã tính rồi để dò cho lần sau là giải thuật căn bản, gọi là phép áp m --> n với n nhỏ hơn m.

Giải thuật ở bài #8 đúngb ra có thể dùng kiểu "trữ lại giá trị đã tính rồi" kiểu mảng như thế nhưng tôi không đưa ra là vì tôi hy vọng có bạn nào đó tìm được cách tính mở quạt (một điểm tự tính ra các điểm chung quanh nó).
Tôi cố tình dùng vòng lặp ngược (for i2 = i To 1 Step -1) là để gợi ý này.
 
Upvote 0
HieuCD đã viết:
Thử cách khác
Mã: 
Sub XYZ()
  Dim Arr(), N&, i&, j&, k&, q&
  Const sRow = 3 'So Dong
  Const sCol = 4 'So Cot
 
  N = sRow * sCol 'So coc
  ReDim Arr(0 To N, 0 To N + 2)
  For i = 1 To sRow
    For j = 1 To sCol
      k = k + 1 'Thu tu dong và cot
      Arr(k, 0) = i & " " & j 'Tieu de dong la Vi tri Coc
      Arr(0, k) = Arr(k, 0) 'Tieu de cot la Vi tri Coc
      Arr(k, N + 1) = i 'Vitri Coc theo dong
      Arr(k, N + 2) = j 'Vitri Coc theo  cot
      Arr(k, k) = 0 ' Duong cheo
      For q = 1 To k - 1
        Arr(q, k) = Sqr((Arr(q, N + 1) - i) ^ 2 + (Arr(q, N + 2) - j) ^ 2)
        Arr(k, q) = Arr(q, k)
      Next q
    Next j
  Next i
  Range("A2").CurrentRegion.ClearContents
  Range("A1").Resize(N + 1, N + 1).Value = Arr
End Sub
Nhấp chuột vào đây để mở rộng...

Đây là 1 đáp số cũng rất hay. Em cám ơn Thầy nhiều!
Cùng 1 đáp số mà có vô số các lời giải khác nhau.
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

T
[Giúp đỡ] Tìm số lượng nhân viên đã tham gia làm lô hàng
Trả lời
3
Đọc
49
hoangtuaotrang_hp_vn
H
hoang.buivan93
Gặp rắc rối về phần công thức hàm tìm kiếm dữ liệu. Nhờ mọi người chỉ giáo giúp ạ.
Trả lời
1
Đọc
27
Hoàng Trọng Nghĩa
Hoàng Trọng Nghĩa
quangminhici
Tặng Addin Word xuất Mail Merge có chức năng cắt ra nhiều file và gửi mail.
    • Thích
Trả lời
8
Đọc
945
thientac
T
A
[Cần Giúp] Excel nhiều người dùng cùng lúc
Trả lời
5
Đọc
118
hvnhpro
H
PhiTQ-ME
  • Question
Nhờ trợ giúp sửa VBA tính diễn giải khối lượng
Trả lời
9
Đọc
128
PhiTQ-ME
PhiTQ-ME
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom