Основные арифметические алгоритмы для работы с длинными числами VBA. Среда использования Microsoft Office.
Перед Вами функции для быстрой арифметики длинных текстовых чисел:
- сложение TotalPluss(a;b);
- вычитниеTotalminuss(a;b);
- умножение Product(a;b);
- деление MathQuotient(a;b);
- сравнение Compare(a;b),
где a и b могут быть положительными и отрицательными числами.
1 По мнению автора гениально отработан алгоритм умножения Product(a;b), принцип счёта основан на китайском графическом способе умножения с помощью линий и точек.
2 В делении MathQuotient(a;b) использованы:
- метод деления столбиком;
- умножение делителя на числа от 1 до 9 с занесением в массив, после чего больше умножений не производится;
- вычитаем, отбрасываем, вычитаем, отбрасываем… Остаток ноль? Прекращаем.
Функция деления немного кривовата и сыровата, но руки к ней пока не тянутся, но в целом рабочая и что-то считает.
MathQuotient$ состоит из следующих двух функций:
- division10(x), не помню, что делает;
- Reciprocal(x), она делит 1 на x.
3 Сложение и вычитание:
- производятся с помощью функций TotalPluss(a;b) и Totalminuss(a;b) где a и b могут быть положительными и отрицательными числами;
- складываем (столбиком) с помощью функции sum(с;d), где с и d – положительные числа;
- вычитаем (столбиком) с помощью функции difference(с;d) , где с и d – положительные числа.
4 Функция формат числа – FormatNumbe(x), откидывает, обрезает, лечит.
1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 14. 15. 16. 17. 18. 19. 20. 21. 22. 23. 24. 25. 26. 27. 28. 29. 30. 31. 32. 33. 34. 35. 36. 37. 38. 39. 40. 41. 42. 43. 44. 45. 46. 47. 48. 49. 50. 51. 52. 53. 54. 55. 56. 57. 58. 59. 60. 61. 62. 63. 64. 65. 66. 67. 68. 69. 70. 71. 72. 73. 74. 75. 76. 77. 78. 79. 80. 81. 82. 83. 84. 85. 86. 87. 88. 89. 90. 91. 92. 93. 94. 95. 96. 97. 98. 99. 100. 101. 102. 103. 104. 105. 106. 107. 108. 109. 110. 111. 112. 113. 114. 115. 116. 117. 118. 119. 120. 121. 122. 123. 124. 125. 126. 127. 128. 129. 130. 131. 132. 133. 134. 135. 136. 137. 138. 139. 140. 141. 142. 143. 144. 145. 146. 147. 148. 149. 150. 151. 152. 153. 154. 155. 156. 157. 158. 159. 160. 161. 162. 163. 164. 165. 166. 167. 168. 169. 170. 171. 172. 173. 174. 175. 176. 177. 178. 179. 180. 181. 182. 183. 184. 185. 186. 187. 188. 189. 190. 191. 192. 193. 194. 195. 196. 197. 198. 199. 200. 201. 202. 203. 204. 205. 206. 207. 208. 209. 210. 211. 212. 213. 214. 215. 216. 217. 218. 219. 220. 221. 222. 223. 224. 225. 226. 227. 228. 229. 230. 231. 232. 233. 234. 235. 236. 237. 238. 239. 240. 241. 242. 243. 244. 245. 246. 247. 248. 249. 250. 251. 252. 253. 254. 255. 256. 257. 258. 259. 260. 261. 262. 263. 264. 265. 266. 267. 268. 269. 270. 271. 272. 273. 274. 275. 276. 277. 278. 279. 280. 281. 282. 283. 284. 285. 286. 287. 288. 289. 290. 291. 292. 293. 294. 295. 296. 297. 298. 299. 300. 301. 302. 303. 304. 305. 306. 307. 308. 309. 310. 311. 312. 313. 314. 315. 316. 317. 318. 319. 320. 321. 322. 323. 324. 325. 326. 327. 328. 329. 330. 331. 332. 333. 334. 335. 336. 337. 338. 339. 340. 341. 342. 343. 344. 345. 346. 347. 348. 349. 350. 351. 352. 353. 354. 355. 356. 357. 358. 359. 360. 361. 362. 363. 364. 365. 366. 367. 368. 369. 370. 371. 372. 373. 374. 375. 376. 377. 378. 379. 380. 381. 382. 383. 384. 385. 386. 387. 388. 389. 390. 391. 392. 393. 394. 395. 396. 397. 398. 399. 400. 401. 402. 403. 404. 405. 406. 407. 408. 409. 410. 411. 412. 413. 414. 415. 416. 417. 418. 419. 420. 421. 422. 423. 424. 425. 426. 427. 428. 429. 430. 431. 432. 433. 434. 435. 436. 437. 438. 439. 440. 441. 442. 443. 444. 445. 446. 447. 448. 449. 450. 451. 452. 453. 454. 455. 456. 457. 458. 459. 460. 461. 462. 463. 464. 465. 466. 467. 468. 469. 470. 471. 472. 473. 474. 475. 476. 477. 478. 479. 480. 481. 482. 483. 484. 485. 486. 487. 488. 489. 490. 491. 492. 493. 494. 495. 496. 497. 498. 499. 500. 501. 502. 503. 504. 505. 506. 507. 508. 509. 510. 511. 512. 513. 514. 515. 516. 517. 518. 519. 520. 521. 522. 523. 524. 525. 526. 527. 528. 529. 530. 531. 532. 533. 534. 535. 536. 537. 538. 539. 540. 541. 542. 543. 544. 545. 546. 547. 548. 549. 550. 551. 552. 553. 554. 555. 556. 557. 558. 559. 560. 561. 562. 563. 564. 565. 566. 567. 568. 569. 570. 571. 572. 573. 574. 575. 576. 577. 578. 579. 580. 581. 582. 583. 584. 585. 586. 587. 588. 589. 590. 591. 592. 593. 594. 595. 596. 597. 598. 599. 600. 601. 602. 603. 604. 605. 606. 607. 608. 609. 610. 611. 612. 613. 614. 615. 616. 617. 618. 619. 620. 621. 622. 623. 624. 625. 626. 627. 628. 629. 630. 631. 632. 633. 634. 635. 636. 637. 638. 639. 640. 641. 642. 643. 644. 645. 646. 647. 648. 649. 650. 651. 652. 653. 654. 655. 656. 657. 658. 659. 660. 661. 662. 663. 664. 665. 666. 667. 668.
Option Explicit
'''' Vladimir-vladimirko@ramler.ru
Public Function FormatNumbe$(ByVal Numbe$)
Dim i%
Numbe$ = Trim(Numbe$)
Numbe$ = Left(Numbe$, 300)
'Очистка нули слева 0000.56, 000787
i% = 0
Do
i% = i% + 1
If Left(Numbe$, 1) <> "0" Then Exit Do
Numbe$ = Right(Numbe$, Len(Numbe$) - 1)
Loop
If Left(Numbe$, 1) = "." Then Numbe$ = "0" & Numbe$
'Очистка нули справа 23.883000
i% = 0
Do
i% = i% + 1
If Mid(Numbe$, i%, 1) = "." Then Exit Do
If i% >= Len(Numbe$) Then Exit Do
Loop
If i% < Len(Numbe$) Then
Do
i% = i% + 1
If Right(Numbe$, 1) <> "0" Then Exit Do
Numbe$ = Left(Numbe$, Len(Numbe$) - 1)
Loop
End If
If Right(Numbe$, 1) = "." Then Numbe$ = Left(Numbe$, Len(Numbe$) - 1)
If Numbe$ = "" Then Numbe$ = 0
If Numbe$ = "-0" Then Numbe$ = 0
FormatNumbe$ = Trim(Numbe$)
End Function
'word length - длина слова
'integer part - целая часть
'fractional part - дробная часть
'numeral - цифра
'displacement
'augend - первое слагаемое
'addend - второе слагаемое
'summand - слагаемое
'sum - сумма
Public Function sum$(ByVal Augend$, ByVal Addend$)
ReDim NumeralAugend%(350)
ReDim NumeralAddend%(350)
ReDim NumeralSum(350) As String
Dim znak$
Dim IntegerPartAugend%, IntegerPartAddend%
Dim FractionalPartAugend%, FractionalPartAddend%
Dim FractionalPartSum%
Dim a$
Dim WordLengthSum%, WordLengthAugend%, WordLengthAddend%, i%, j%, n%
Augend$ = FormatNumbe(Augend$)
Addend$ = FormatNumbe$(Addend$)
WordLengthAugend% = Len(Augend$)
WordLengthAddend% = Len(Addend$)
IntegerPartAugend% = 0: IntegerPartAugend% = InStr(Augend$, "."): If IntegerPartAugend% = 0 Then IntegerPartAugend% = WordLengthAugend%
If IntegerPartAugend% <> WordLengthAugend% Then Augend$ = Mid(Augend$, 1, IntegerPartAugend% - 1) & Mid(Augend$, IntegerPartAugend% + 1, WordLengthAugend% - IntegerPartAugend%): WordLengthAugend% = WordLengthAugend% - 1: IntegerPartAugend% = IntegerPartAugend% - 1
IntegerPartAddend% = 0: IntegerPartAddend% = InStr(Addend$, "."): If IntegerPartAddend% = 0 Then IntegerPartAddend% = WordLengthAddend%
If IntegerPartAddend% <> WordLengthAddend% Then Addend$ = Mid(Addend$, 1, IntegerPartAddend% - 1) & Mid(Addend$, IntegerPartAddend% + 1, WordLengthAddend% - IntegerPartAddend%): WordLengthAddend% = WordLengthAddend% - 1: IntegerPartAddend% = IntegerPartAddend% - 1
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
FractionalPartAugend% = WordLengthAugend% - IntegerPartAugend%
FractionalPartAddend% = WordLengthAddend% - IntegerPartAddend%
If FractionalPartAugend% > FractionalPartAddend% Then
For i% = 1 To FractionalPartAugend% - FractionalPartAddend%
Addend$ = Addend$ & "0"
WordLengthAddend% = WordLengthAddend% + 1
Next i%
End If
If FractionalPartAugend% < FractionalPartAddend% Then
For i% = 1 To FractionalPartAddend% - FractionalPartAugend%
Augend$ = Augend$ & "0"
WordLengthAugend% = WordLengthAugend% + 1
Next i%
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
For i% = 1 To WordLengthAugend%
NumeralAugend%(i%) = Mid(Augend$, WordLengthAugend% + 1 - i%, 1)
Next i%
For j% = 1 To WordLengthAddend%
NumeralAddend%(j%) = Mid(Addend$, WordLengthAddend% + 1 - j%, 1)
Next j%
If WordLengthAugend% < WordLengthAddend% Then WordLengthSum% = WordLengthAddend% Else WordLengthSum% = WordLengthAugend%
For n% = 1 To WordLengthSum%
NumeralSum(n%) = NumeralAugend%(n%) + NumeralAddend%(n%)
Next n%
For n% = 1 To WordLengthSum% + 1
NumeralSum(n% + 1) = Val(NumeralSum(n% + 1)) + Val(Mid(NumeralSum(n%), 1, Len(NumeralSum(n%)) - 1))
NumeralSum(n%) = Right(NumeralSum(n%), 1)
sum$ = NumeralSum(n%) & sum$
Next n%
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
FractionalPartSum% = 0
If NumeralSum(WordLengthSum% + 1) = "0" Then sum$ = Mid(sum$, 2, Len(sum$) - 1) 'Else FractionalPartSum% = FractionalPartSum% + 1
If IntegerPartAugend% > IntegerPartAddend% Then FractionalPartSum% = IntegerPartAugend% - 1 Else FractionalPartSum% = IntegerPartAddend% - 1
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If NumeralSum(WordLengthSum% + 1) <> "0" Then FractionalPartSum% = FractionalPartSum% + 1
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If Left(sum$, 1) = "0" Then
sum$ = Left(sum$, 1) & "." & Mid(sum$, 2)
Else
sum$ = Left(sum$, FractionalPartSum% + 1) & "." & Mid(sum$, FractionalPartSum% + 2)
End If
sum$ = FormatNumbe$(sum$)
End Function
'descend - уменьшаемое
'subtrahend - вычитаемое
'difference - разность
Public Function difference$(ByVal Descend$, ByVal Subtrahend$)
ReDim NumeralDescend%(350)
ReDim NumeralSubtrahend%(350)
ReDim NumeralDifference$(350)
Dim znak$
Dim IntegerPartDescend%, IntegerPartSubtrahend%, IntegerPartDifference%
Dim FractionalPartDescend%, FractionalPartSubtrahend
Dim WordLengthDifference%, WordLengthDescend%, WordLengthSubtrahend%, i%, j%, n%
Descend$ = FormatNumbe$(Descend$)
Subtrahend$ = FormatNumbe$(Subtrahend$)
WordLengthDescend% = Len(Descend$)
WordLengthSubtrahend% = Len(Subtrahend$)
If Left(Descend$, 1) = "-" Then
WordLengthDescend% = WordLengthDescend% - 1
Descend$ = Mid(Descend$, 2, WordLengthDescend%)
End If
If Left(Subtrahend$, 1) = "-" Then
WordLengthSubtrahend% = WordLengthSubtrahend% - 1
Subtrahend$ = Mid(Subtrahend$, 2, WordLengthSubtrahend%)
End If
IntegerPartDescend% = 0: Do: IntegerPartDescend% = IntegerPartDescend% + 1: Loop Until Mid(Descend$, IntegerPartDescend%, 1) = "." Or IntegerPartDescend% = WordLengthDescend%
If IntegerPartDescend% <> WordLengthDescend% Then Descend$ = Mid(Descend$, 1, IntegerPartDescend% - 1) & Mid(Descend$, IntegerPartDescend% + 1, WordLengthDescend% - IntegerPartDescend%): WordLengthDescend% = WordLengthDescend% - 1: IntegerPartDescend% = IntegerPartDescend% - 1
IntegerPartSubtrahend% = 0: Do: IntegerPartSubtrahend% = IntegerPartSubtrahend% + 1: Loop Until Mid(Subtrahend$, IntegerPartSubtrahend%, 1) = "." Or IntegerPartSubtrahend% = WordLengthSubtrahend%
If IntegerPartSubtrahend% <> WordLengthSubtrahend% Then Subtrahend$ = Mid(Subtrahend$, 1, IntegerPartSubtrahend% - 1) & Mid(Subtrahend$, IntegerPartSubtrahend% + 1, WordLengthSubtrahend% - IntegerPartSubtrahend%): WordLengthSubtrahend% = WordLengthSubtrahend% - 1: IntegerPartSubtrahend% = IntegerPartSubtrahend% - 1
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
FractionalPartDescend% = WordLengthDescend% - IntegerPartDescend%
FractionalPartSubtrahend = WordLengthSubtrahend% - IntegerPartSubtrahend%
If FractionalPartDescend% > FractionalPartSubtrahend Then
For i% = 1 To FractionalPartDescend% - FractionalPartSubtrahend
Subtrahend$ = Subtrahend$ & "0"
WordLengthSubtrahend% = WordLengthSubtrahend% + 1
Next i%
End If
If FractionalPartDescend% < FractionalPartSubtrahend Then
For i% = 1 To FractionalPartSubtrahend - FractionalPartDescend%
Descend$ = Descend$ & "0"
WordLengthDescend% = WordLengthDescend% + 1
Next i%
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
For i% = 1 To WordLengthDescend%
NumeralDescend%(i%) = Mid(Descend$, WordLengthDescend% + 1 - i%, 1)
Next i%
For j% = 1 To WordLengthSubtrahend%
NumeralSubtrahend%(j%) = Mid(Subtrahend$, WordLengthSubtrahend% + 1 - j%, 1)
Next j%
If WordLengthDescend% < WordLengthSubtrahend% Then WordLengthDifference% = WordLengthSubtrahend% Else WordLengthDifference% = WordLengthDescend%
For n% = 1 To WordLengthDifference%
If NumeralDescend%(n%) >= NumeralSubtrahend%(n%) Then
NumeralDifference$(n%) = NumeralDescend%(n%) - NumeralSubtrahend%(n%)
Else
NumeralDifference$(n%) = 10 + NumeralDescend%(n%) - NumeralSubtrahend%(n%)
NumeralDescend%(n% + 1) = NumeralDescend%(n% + 1) - 1
End If
Next n%
For n% = 1 To WordLengthDifference% + 1
NumeralDifference$(n% + 1) = Val(NumeralDifference$(n% + 1)) - Val(Mid(NumeralDifference$(n%), 1, Len(NumeralDifference$(n%)) - 1))
NumeralDifference$(n%) = Right(NumeralDifference$(n%), 1)
difference$ = NumeralDifference$(n%) & difference$
Next n%
If NumeralDifference$(WordLengthDifference% + 1) = "0" Then difference$ = Mid(difference$, 2, Len(difference$) - 1) 'Else IntegerPartDifference% = IntegerPartDifference% + 1
If IntegerPartDescend% > IntegerPartSubtrahend% Then IntegerPartDifference% = IntegerPartDescend% - 1 Else IntegerPartDifference% = IntegerPartSubtrahend% - 1
difference$ = Left(difference$, IntegerPartDifference% + 1) & "." & Mid(difference$, IntegerPartDifference% + 2)
difference$ = FormatNumbe(difference$)
End Function
'total - итог
'augend - первое слагаемое
'addend - второе слагаемое
'summand - слагаемое
'sum - сумма
'substitute - заместитель
Public Function TotalPluss$(ByVal TotalAugend$, ByVal TotalAddend$)
Dim TotalCharacterAugend As Byte
Dim TotalCharacterAddend As Byte
Dim TotalPlussSubstitute$
TotalAugend$ = FormatNumbe$(TotalAugend$)
TotalAddend$ = FormatNumbe$(TotalAddend$)
If Left(TotalAugend$, 1) = "-" Then
TotalCharacterAugend = 0
TotalAugend$ = Mid(TotalAugend$, 2, Len(TotalAugend$) - 1)
Else
TotalCharacterAugend = 2
End If
If Left(TotalAddend$, 1) = "-" Then
TotalAddend$ = Mid(TotalAddend$, 2, Len(TotalAddend$) - 1)
TotalCharacterAddend = 0
Else
TotalCharacterAddend = 2
End If
If compare(TotalAugend$, TotalAddend$) = 0 Then
If TotalCharacterAugend = 2 And TotalCharacterAddend = 2 Then TotalPluss$ = sum(TotalAugend$, TotalAddend$)
If TotalCharacterAugend = 0 And TotalCharacterAddend = 0 Then TotalPluss$ = "-" & sum(TotalAugend$, TotalAddend$)
TotalPlussSubstitute$ = TotalAugend$: TotalAugend$ = TotalAddend$: TotalAddend$ = TotalPlussSubstitute$
If TotalCharacterAugend = 2 And TotalCharacterAddend = 0 Then TotalPluss$ = "-" & difference(TotalAugend$, TotalAddend$)
If TotalCharacterAugend = 0 And TotalCharacterAddend = 2 Then TotalPluss$ = difference(TotalAugend$, TotalAddend$)
Else
If TotalCharacterAugend = 0 And TotalCharacterAddend = 2 Then TotalPluss$ = "-" & difference(TotalAugend$, TotalAddend$)
If TotalCharacterAugend = 2 And TotalCharacterAddend = 2 Then TotalPluss$ = sum(TotalAugend$, TotalAddend$) ''''''''''
If TotalCharacterAugend = 0 And TotalCharacterAddend = 0 Then TotalPluss$ = "-" & sum(TotalAugend$, TotalAddend$) ''''''''''
If TotalCharacterAugend = 2 And TotalCharacterAddend = 0 Then TotalPluss$ = difference(TotalAugend$, TotalAddend$)
End If
TotalPluss$ = FormatNumbe$(TotalPluss$)
End Function
'total - итог
'substitute - заместитель
'descend - уменьшаемое
'subtrahend - вычитаемое
'difference - разность
Public Function Totalminuss$(ByVal TotalDescend$, ByVal TotalSubstrahend$)
Dim TotalCharacterDescend As Byte
Dim TotalCharacterSubstrahend As Byte
Dim TotalminussSubstitute$
TotalDescend$ = FormatNumbe$(TotalDescend$)
TotalSubstrahend$ = FormatNumbe$(TotalSubstrahend$)
If Left(TotalDescend$, 1) = "-" Then
TotalCharacterDescend = 0
TotalDescend$ = Mid(TotalDescend$, 2, Len(TotalDescend$) - 1)
Else
TotalCharacterDescend = 2
End If
If Left(TotalSubstrahend$, 1) = "-" Then
TotalSubstrahend$ = Mid(TotalSubstrahend$, 2, Len(TotalSubstrahend$) - 1)
TotalCharacterSubstrahend = 0
Else
TotalCharacterSubstrahend = 2
End If
If compare(TotalDescend$, TotalSubstrahend$) = 0 Then
If TotalCharacterDescend = 2 And TotalCharacterSubstrahend = 0 Then Totalminuss$ = sum(TotalDescend$, TotalSubstrahend$)
If TotalCharacterDescend = 0 And TotalCharacterSubstrahend = 2 Then Totalminuss$ = "-" & sum(TotalDescend$, TotalSubstrahend$)
TotalminussSubstitute$ = TotalDescend$: TotalDescend$ = TotalSubstrahend$: TotalSubstrahend$ = TotalminussSubstitute$
If TotalCharacterDescend = 0 And TotalCharacterSubstrahend = 0 Then Totalminuss$ = difference(TotalDescend$, TotalSubstrahend$)
If TotalCharacterDescend = 2 And TotalCharacterSubstrahend = 2 Then Totalminuss$ = "-" & difference(TotalDescend$, TotalSubstrahend$)
Else
If TotalCharacterDescend = 2 And TotalCharacterSubstrahend = 0 Then Totalminuss$ = sum(TotalDescend$, TotalSubstrahend$)
If TotalCharacterDescend = 0 And TotalCharacterSubstrahend = 2 Then Totalminuss$ = "-" & sum(TotalDescend$, TotalSubstrahend$)
If TotalCharacterDescend = 2 And TotalCharacterSubstrahend = 2 Then Totalminuss$ = difference(TotalDescend$, TotalSubstrahend$)
If TotalCharacterDescend = 0 And TotalCharacterSubstrahend = 0 Then Totalminuss$ = "-" & difference(TotalDescend$, TotalSubstrahend$)
End If
Totalminuss$ = FormatNumbe$(Totalminuss$)
End Function
Public Function compare(ByVal ao$, ByVal bo$) As Byte
Dim la%, lb%, ia%, ib%, i%
Dim znakao, znakbo
ao$ = FormatNumbe$(ao$)
bo$ = FormatNumbe$(bo$)
la% = Len(ao$)
lb% = Len(bo$)
znakbo = 0
znakao = 0
ia% = InStr(ao$, "."): If ia% = 0 Then ia% = la%
If ia% <> la% Then ao$ = Mid(ao$, 1, ia% - 1) & Mid(ao$, ia% + 1, la% - ia%): la% = la% - 1: ia% = ia% - 1
ib% = InStr(bo$, "."): If ib% = 0 Then ib% = lb%
If ib% <> lb% Then bo$ = Mid(bo$, 1, ib% - 1) & Mid(bo$, ib% + 1, lb% - ib%): ib% = ib% - 1
If Left(ao$, 1) = "-" Then znakao = -1: ia% = ia% - 1: ao$ = Mid(ao$, 2)
If Left(bo$, 1) = "-" Then znakbo = -1: ib% = ib% - 1: bo$ = Mid(bo$, 2)
If znakao = -1 And znakbo = 0 Then compare = 0: Exit Function
If znakao = 0 And znakbo = -1 Then compare = 2: Exit Function
If ia > ib Then compare = 2: Exit Function
If ia < ib Then compare = 0: Exit Function
If znakao = -1 And znakbo = -1 Then compare = -StrComp(ao$, bo$) + 1
If znakao = 0 And znakbo = 0 Then compare = StrComp(ao$, bo$) + 1
End Function
Public Function division10(ByVal numeral$)
Dim IntegerPartDivisor%
Dim WordLengthDivisor%
Dim Divisor$
Dim Nuuul
Dim i%
numeral$ = FormatNumbe$(numeral$)
'Найти точку
Divisor$ = numeral$
WordLengthDivisor% = Len(Divisor$)
IntegerPartDivisor% = 0: Do: IntegerPartDivisor% = IntegerPartDivisor% + 1: Loop Until Mid(Divisor$, IntegerPartDivisor%, 1) = "." Or IntegerPartDivisor% = WordLengthDivisor%
If IntegerPartDivisor% <> WordLengthDivisor% Then Divisor$ = Mid(Divisor$, 1, IntegerPartDivisor% - 1) & Mid(Divisor$, IntegerPartDivisor% + 1, WordLengthDivisor% - IntegerPartDivisor%): WordLengthDivisor% = WordLengthDivisor% - 1: IntegerPartDivisor% = IntegerPartDivisor% - 1
'division10 = IntegerPartDivisor%
If IntegerPartDivisor% <> 1 Then
Nuuul = ""
For i% = 1 To IntegerPartDivisor% - 2
Nuuul = Nuuul & "0"
Next i%
division10 = "0." & Nuuul & "1"
Else
Nuuul = ""
For i% = 1 To WordLengthDivisor% - IntegerPartDivisor%
Nuuul = Nuuul & "0"
Next i%
division10 = "1" & Nuuul
End If
End Function
'division - деление
'dividend - делимое
'divisor - делитель
'MathQuotient- частное
'displacement - сдвиг
'numeral - цифра
'Integer part - целая часть
'fractional part - дробная часть
'word length - длина слова
'PartZero
'character. letter. mark. digit. sign. symbol - знак
'sign digit - цифра знака ( определяющая знак ); знаковый разряд
'arithmetial - арифметический
'reciprocal numbe - обратное число
Public Function Reciprocal$(ByVal Divisor$)
'word length
'division - деление
'dividend - делимое
'divisor - делитель
'Dim WordLengthDivisor%
Dim Dividend$
Dim i%
Dim m%
Dim t%
Dim a$(350)
Dim c$(10)
Dim ProductCharacter$
Dim iT%
Dim IntegerPartDivisor%
Dim WordLengthDivisor%
Dim BWordLengthDivisor%
Dim Nuuul$
Dim ADivisor$
Dim Bdivisor$
Divisor$ = FormatNumbe(Divisor$)
ProductCharacter$ = ""
If Left(Divisor$, 1) = "-" Then ProductCharacter$ = "-"
If Left(Divisor$, 1) = "-" Then Divisor$ = Mid(Divisor$, 2)
WordLengthDivisor% = Len(Divisor$)
ADivisor$ = Divisor$
IntegerPartDivisor% = 0: Do: IntegerPartDivisor% = IntegerPartDivisor% + 1: Loop Until Mid(Divisor$, IntegerPartDivisor%, 1) = "." Or IntegerPartDivisor% = WordLengthDivisor%
If IntegerPartDivisor% <> WordLengthDivisor% Then Divisor$ = Mid(Divisor$, 1, IntegerPartDivisor% - 1) & Mid(Divisor$, IntegerPartDivisor% + 1, WordLengthDivisor% - IntegerPartDivisor%): WordLengthDivisor% = WordLengthDivisor% - 1: IntegerPartDivisor% = IntegerPartDivisor% - 1
iT% = 0
For i% = 1 To 350
If Left(Divisor$, 1) = "0" Then Divisor$ = Mid(Divisor$, 2)
If Left(Divisor$, 1) = "." Then Divisor$ = Mid(Divisor$, 2)
If Val(Left(Divisor$, 1)) > 0 Then Exit For
iT% = iT% + 1
Next i%
Divisor$ = Left(Divisor$, IntegerPartDivisor% - 1) & Mid(Divisor$, IntegerPartDivisor%)
For i% = 1 To WordLengthDivisor% + 1
If Mid(Divisor$, 1, 1) = "0" Then
Divisor$ = Right(Divisor$, Len(Divisor$) - 1)
Else
Exit For
End If
Next i%
Bdivisor$ = Divisor$
BWordLengthDivisor% = Len(Divisor$)
For i% = 1 To BWordLengthDivisor% - 1
If Right(Bdivisor$, 1) = "0" Then
Bdivisor$ = Left(Bdivisor$, Len(Bdivisor$) - 1)
Else
Exit For
End If
Next i%
Dividend$ = "1"
If Divisor$ = "0" Then Reciprocal$ = "N/0": Exit Function
If Bdivisor$ = "1" Then
Reciprocal$ = ProductCharacter$ & division10(ADivisor$)
Exit Function
End If
For i% = 0 To 10
c$(i%) = product(i%, Divisor$)
Next i%
c$(0) = "0"
For t% = 1 To 350
m% = 0
Dividend$ = Dividend$ & "0"
Do
m% = m% + 1
If compare(Dividend$, c$(m%)) = 0 Then Exit Do
Loop
Dividend$ = Totalminuss(Dividend$, c$(m% - 1))
a$(t%) = m% - 1
Next t%
Reciprocal$ = ""
For i% = 1 To 350
Reciprocal$ = Reciprocal$ & a(i%)
Next i%
Reciprocal$ = FormatNumbe(Reciprocal$)
If IntegerPartDivisor% = 1 Then
If Val(Mid(ADivisor$, 1, 3)) < 1 Then
Reciprocal$ = Left(Reciprocal$, iT% + 1) & "." & Mid(Reciprocal$, iT% + 2)
Else
Reciprocal$ = Left(Reciprocal$, iT%) & "." & Mid(Reciprocal$, iT% + 1)
End If
Else
Nuuul = ""
For i% = 1 To IntegerPartDivisor% - 1
Nuuul = Nuuul & "0"
Next i%
Reciprocal$ = Nuuul & Reciprocal$
If Left(Reciprocal$, 1) = "0" Then Reciprocal$ = "0." & Reciprocal$
End If
If Left(Reciprocal$, 1) = "." Then Reciprocal$ = "0" & Reciprocal$
Reciprocal$ = ProductCharacter$ & Reciprocal$
End Function
'dividend - делимое
'divisor - делитель
'MathQuotient- частное
'displacement - сдвиг
'numeral - цифра
'Integer part - целая часть
'fractional part - дробная часть
'word length - длина слова
'PartZero
'character. letter. mark. digit. sign. symbol - знак
'sign digit - цифра знака ( определяющая знак ); знаковый разряд
'arithmetial - арифметический
'reciprocal numbe - обратное число
Public Function MathQuotient$(ByVal Dividend$, ByVal Divisor$) 'divisor
Divisor$ = Reciprocal(Divisor$)
MathQuotient$ = product(Dividend$, Divisor$)
End Function
'product - произведение
'multiplicand - множимое
'multiplier. factor - множитель
'multiply - умножать
'word length - длина слова
'integer part - целая часть
'fractional part - дробная часть
'numeral - цифра
'displacement
'zero - ноль
'Public NameArray(1 To 600) As String
'Public uNameArray(1 To 600) As String
Public Function product$(ByVal Multiplicand$, ByVal Factor$)
Dim FractionalPartMultiplicand%, FractionalPartFactor%
Dim WordLengthMultiplicand%, WordLengthFactor%
Dim IntegerPartMultiplicand%, IntegerPartFactor%
Dim Displacement%
ReDim NumeralProduct(600) As String
ReDim NumeralMultiplicand(600) As Byte
ReDim NumeralFactor(600) As Byte
Dim PartZeroProduct$
Dim k%, n%, i%, j%
Dim ProductCharacter$
Dim GM As String
Multiplicand$ = FormatNumbe(Multiplicand$)
Factor$ = FormatNumbe(Factor$)
Multiplicand$ = Trim(Multiplicand$): WordLengthMultiplicand% = Len(Multiplicand$)
Factor$ = Trim(Factor$): WordLengthFactor% = Len(Factor$)
ProductCharacter$ = ""
If Left(Multiplicand$, 1) = "-" And Left(Factor$, 1) <> "-" Then ProductCharacter$ = "-"
If Left(Multiplicand$, 1) <> "-" And Left(Factor$, 1) = "-" Then ProductCharacter$ = "-"
If Left(Multiplicand$, 1) = "-" Then Multiplicand$ = Mid(Multiplicand$, 2)
WordLengthMultiplicand% = Len(Multiplicand$)
If Left(Factor$, 1) = "-" Then Factor$ = Mid(Factor$, 2)
WordLengthFactor% = Len(Factor$)
IntegerPartMultiplicand% = 0: Do: IntegerPartMultiplicand% = IntegerPartMultiplicand% + 1: Loop Until Mid(Multiplicand$, IntegerPartMultiplicand%, 1) = "." Or IntegerPartMultiplicand% = WordLengthMultiplicand%
If IntegerPartMultiplicand% <> WordLengthMultiplicand% Then Multiplicand$ = Mid(Multiplicand$, 1, IntegerPartMultiplicand% - 1) & Mid(Multiplicand$, IntegerPartMultiplicand% + 1, WordLengthMultiplicand% - IntegerPartMultiplicand%): WordLengthMultiplicand% = WordLengthMultiplicand% - 1: IntegerPartMultiplicand% = IntegerPartMultiplicand% - 1
IntegerPartFactor% = 0: Do: IntegerPartFactor% = IntegerPartFactor% + 1: Loop Until Mid(Factor$, IntegerPartFactor%, 1) = "." Or IntegerPartFactor% = WordLengthFactor%
If IntegerPartFactor% <> WordLengthFactor% Then Factor$ = Mid(Factor$, 1, IntegerPartFactor% - 1) & Mid(Factor$, IntegerPartFactor% + 1, WordLengthFactor% - IntegerPartFactor%): WordLengthFactor% = WordLengthFactor% - 1: IntegerPartFactor% = IntegerPartFactor% - 1
FractionalPartMultiplicand% = 0: Do: FractionalPartMultiplicand% = FractionalPartMultiplicand% + 1: Loop Until Mid(Multiplicand$, FractionalPartMultiplicand%, 1) <> "0"
FractionalPartFactor% = 0: Do: FractionalPartFactor% = FractionalPartFactor% + 1: Loop Until Mid(Factor$, FractionalPartFactor%, 1) <> "0"
For i% = 1 To WordLengthMultiplicand%
NumeralMultiplicand(i) = Mid(Multiplicand$, WordLengthMultiplicand% + 1 - i%, 1)
Next i%
For j% = 1 To WordLengthFactor%
NumeralFactor(j) = Mid(Factor$, WordLengthFactor% + 1 - j%, 1)
Next j%
k% = 0
For i% = 1 To WordLengthMultiplicand%
For j% = 1 To WordLengthFactor%
n% = j% + k%
NumeralProduct(n%) = Val(NumeralProduct(n%)) + Val(NumeralMultiplicand(i%)) * Val(NumeralFactor(j%))
NumeralProduct(n% + 1) = Val(NumeralProduct(n% + 1)) + Val(Mid(NumeralProduct(n%), 1, Len(NumeralProduct(n%)) - 1))
NumeralProduct(n%) = Right(CByte(NumeralProduct(n%)), 1)
Next j%
k% = k% + 1
Next i%
For n% = 1 To WordLengthMultiplicand% + WordLengthFactor%
product$ = CByte(NumeralProduct(n%)) & product$
Next n%
n% = 0: Do: n% = n% + 1: Loop Until Mid(product$, n%, 1) <> 0
If n% <> 0 Then product$ = Mid(product$, n%)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Multiplicand$ = Mid(Multiplicand$, FractionalPartMultiplicand%)
Factor$ = Mid(Factor$, FractionalPartFactor%)
If NumeralProduct(Len(Multiplicand$) + Len(Factor$)) = "0" Then
Displacement% = 0
Else
Displacement% = 1
End If
If -(FractionalPartFactor% + FractionalPartMultiplicand%) + IntegerPartMultiplicand% + IntegerPartFactor% + 2 > 0 Then
product$ = Left(product$, IntegerPartMultiplicand% + IntegerPartFactor% - (FractionalPartFactor% + FractionalPartMultiplicand%) + Displacement% + 1) & "." & Mid(product$, IntegerPartMultiplicand% + IntegerPartFactor% - (FractionalPartFactor% + FractionalPartMultiplicand%) + Displacement% + 2)
Else
For n% = 1 To -(IntegerPartMultiplicand% + IntegerPartFactor% - (FractionalPartFactor% + FractionalPartMultiplicand%) + Displacement% + 1)
PartZeroProduct$ = PartZeroProduct$ & "0"
Next n%
product$ = "0." & PartZeroProduct$ & product$
End If
product$ = ProductCharacter$ & FormatNumbe(product$)
End Function
|