mrdime
Silver Member | Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
Attribute VB_Name = "Tanya_DBReserve"
Sub DBReserve()
Dim c As Integer
Dim r As Integer
Dim ra As Integer
Dim n As Integer
Dim AL(1 To 200, 1 To 2) As String
Dim i As Integer, j As Integer
Dim InNum As Integer
Dim myWb As Workbook
Dim mySh As Worksheet
Dim DocPath As String
Dim CurDate As String
Application.ScreenUpdating = False
DocPath = "c:\Temp\Tanya\Adm\Lists\DB"
CurDate = CStr(Date)
r = ActiveSheet.UsedRange.RowS.Count
i = 0
For n = 2 To r
If IsNumeric(Cells(n, 1).Value) And Cells(n, 1).Value > 0 Then
i = i + 1
For j = 1 To 2
AL(i, j) = Trim(Cells(n, 4 + 3 ^ (j - 1)).Value) + " " + Trim(Cells(n, 5 + 3 ^ (j - 1)).Value)
Next j
End If
Next n
Set myWb = Workbooks.Open(DocPath + "\" + "TotalList.xlsx")
myWb.SaveAs (DocPath + "\" + "TotalList_" + CurDate + "_reserve.xlsx")
myWb.Close
Set myWb = Workbooks.Open(DocPath + "\" + "TotalList.xlsx")
Set mySh = myWb.Worksheets("Sheet1_full")
mySh.Activate
ra = ActiveSheet.UsedRange.RowS.Count
InNum = Cells(ra, 1).Value
For n = 1 To i
Cells(ra + n, 1).Value = InNum + n
For j = 1 To 2
Cells(ra + n, j + 1).Value = AL(n, j)
Next j
Next n
Application.ScreenUpdating = True
MsgBox ("Программа завершилась успешно.")
End Sub
|
