[mwz]

jordan_74, а почему вы определяете objFSO не перед первым использованием, а в конце скрипта?

[jordan_74]

jordan_74, а почему вы определяете objFSO не перед первым использованием, а в конце скрипта? »

Я привел только кусок кода, возможно получилось вырванным из контекста, я только учусь) учту все замечания

[Iska]

Вопрос, как эту самую(е) папки создавать в папке Архив? »

Например, указывать полный путь — если Вы используете создание каталога посредством метода .CreateFolder() класса Scripting.FileSystemObject. Кроме этого метода Вы можете использовать метод .Add() коллекции Folders. И тот, и другой методы возвращают объект типа Folder.

Почему то создается в корне C:\Реестр\ »

Вероятно Ваш скрипт там находится. Оттуда Вы его запускаете, и потому данный каталог является текущим для него:

Скрытый текст

Я бы изобразил нечто подобное:

Код:

Option Explicit

Dim strRootFolder
Dim strArchiveFolder

Dim objFSO

Dim objRootFolder
Dim objArchiveFolder
Dim strPath2ArchiveFolder

Dim objSWbemObjectEx

Dim objNowFolder


strRootFolder    = "C:\Реестр"
strArchiveFolder = "Архив"

Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")

If objFSO.FolderExists(strRootFolder) Then
	Set objRootFolder = objFSO.GetFolder(strRootFolder)
	
	strPath2ArchiveFolder = objFSO.BuildPath(strRootFolder, strArchiveFolder)
	
	If Not objFSO.FolderExists(strPath2ArchiveFolder) Then
		Set objArchiveFolder = objRootFolder.SubFolders.Add(strArchiveFolder)
	Else
		Set objArchiveFolder = objFSO.GetFolder(strPath2ArchiveFolder)
	End If
	
	For Each objSWbemObjectEx In WScript.CreateObject("WbemScripting.SWbemLocator").ConnectServer(".", "root\cimv2").ExecQuery("SELECT LocalDateTime FROM Win32_OperatingSystem")
		Set objNowFolder = objArchiveFolder.SubFolders.Add(Left(objSWbemObjectEx.LocalDateTime, 8))
		
		Exit For
	Next
	
	'...
	'...
	'...
	
	Set objNowFolder     = Nothing
	Set objArchiveFolder = Nothing
	Set objRootFolder    = Nothing
Else
	WScript.Echo "Can't find root folder [" & strRootFolder & "]."
	WScript.Quit 1
End If

Set objFSO = Nothing

WScript.Quit 0

P.S. И никаких On Error Resume Next без веских причин!

[jordan_74]

Iska,
Попытался встроить данный кусок в код.
Сработало, папка с текущей датой в имени создалась в папке Архив. Но сама папка Архив создалась не в том месте, почему то... она создалась в папке Итог - C:\Реестр\Итог\Архив\20181129, а верный вариант C:\Реестр\Архив\20181129
Просьба подсказать где ошибка..

Скрытый текст

Option Explicit

Const xlCSV = 6
Const xlWindows = 2

Dim s,d,m,y
Dim Log 'Лог-файл

Dim strSourceFolder ' Папка Реестр

Dim strTemplateFile ' Файл шаблона

Dim strRelativeDestFolder ' Папка "Итог"


Dim strRootFolder ' Папка C:\Реестр
Dim strArchiveFolder ' Папка архив
Dim objRootFolder
Dim objArchiveFolder
Dim strPath2ArchiveFolder

Dim objSWbemObjectEx

Dim objNowFolder

Dim strLogDestFolder 'Папка, в которой будут создаваться лог-файлы

Dim objFSO
Dim objExcel

Dim objFile

Dim objTemplateFile
Dim objSourceFile

Dim i
Dim strDestFile

Dim strLogDestFile

Dim SumSourceFile 'Сумма по реестру
Dim SumDestFile 'Сумма по чекам
Dim SumTotal 'Общая сумма

Dim CountSourceFiles 'Для подсчета файлов реестра
CountSourceFiles = 0

Dim anyValue

'Здесь указать полный адрес папки с файлами реестра:
strSourceFolder = "C:\Реестр\реестр"

strTemplateFile = "C:\Реестр\Шаблон\check.csv"
strRelativeDestFolder = "..\Итог"
strLogDestFolder = "C:\Касса"
strArchiveFolder = "Архив"
strRootFolder = "C:\Реестр"

'If WScript.Arguments.Count = 1 Then
' strSourceFolder = WScript.Arguments.Item(0)

Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
'Если файл шаблона существует
If objFSO.FileExists(strTemplateFile) Then
' Если папка "реестр" существует
If objFSO.FolderExists(strSourceFolder) Then


strRootFolder = objFSO.GetAbsolutePathName(objFSO.BuildPath(strSourceFolder, strRelativeDestFolder))
If Not objFSO.FolderExists(strRootFolder) Then
objFSO.CreateFolder strRootFolder
End If

'Создание папки Касса:
If Not objFSO.FolderExists(strLogDestFolder) Then
objFSO.CreateFolder strLogDestFolder
End If

'Создание папки Архив:
Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")

If objFSO.FolderExists(strRootFolder) Then
Set objRootFolder = objFSO.GetFolder(strRootFolder)

strPath2ArchiveFolder = objFSO.BuildPath(strRootFolder, strArchiveFolder)

If Not objFSO.FolderExists(strPath2ArchiveFolder) Then
Set objArchiveFolder = objRootFolder.SubFolders.Add(strArchiveFolder)
Else
Set objArchiveFolder = objFSO.GetFolder(strPath2ArchiveFolder)
End If

For Each objSWbemObjectEx In WScript.CreateObject("WbemScripting.SWbemLocator").ConnectServer(".", "root\cimv2").ExecQuery("SELECT LocalDateTime FROM Win32_OperatingSystem")
Set objNowFolder = objArchiveFolder.SubFolders.Add(Left(objSWbemObjectEx.LocalDateTime, 8))

Exit For
Next

Set objNowFolder = Nothing
Set objArchiveFolder = Nothing
Set objRootFolder = Nothing
Else
WScript.Echo "Can't find root folder [" & strRootFolder & "]."
WScript.Quit 3
End If

Set objExcel = Nothing

For Each objFile In objFSO.GetFolder(strSourceFolder).Files

'Подсчет количества файлов реестра:
CountSourceFiles = CountSourceFiles + 1

Select Case LCase(objFSO.GetExtensionName(objFile.Name))
Case "xls", "xlsx"
If objExcel Is Nothing Then
Set objExcel = WScript.CreateObject("Excel.Application")
End If

objExcel.Workbooks.OpenText strTemplateFile, , , , , , , , , , , , , , , , , True
Set objTemplateFile = objExcel.Workbooks.Item(1)

Set objSourceFile = objExcel.Workbooks.Open(objFile.Path, False, True)

For i = 1 To objSourceFile.Worksheets.Item(1).UsedRange.Rows.Count - 2
With objTemplateFile.Worksheets.Item(1)
anyValue = objSourceFile.Worksheets.Item(1).Cells.Item(i + 1, 5).Value

.Range("B3").Value = anyValue
.Range("F2").Value = anyValue

anyValue = objSourceFile.Worksheets.Item(1).Cells.Item(i + 1, 6).Value

.Range("D3").Value = anyValue
.Range("D4").Value = anyValue
.Range("H3").Value = anyValue
'Подсчет НДС
.Range("L3").Value = Fix((anyValue * 18 / 118 + 0.005) * 100) / 100

'Подсчет общей суммы:
SumTotal = SumTotal + anyValue

'Подсчет суммы по реестру:
SumSourceFile = SumSourceFile + anyValue

'Подсчет суммы по чекам:
SumDestFile = SumDestFile + .Range("H3").Value

End With
' Создаем имя файла
strDestFile = objFSO.BuildPath(strRootFolder, objFSO.GetBaseName(strTemplateFile) & "_" & objFSO.GetBaseName(objFile.Name) & "_" & Right("000" & CStr(i), 3) & "." & objFSO.GetExtensionName(strTemplateFile))

If objFSO.FileExists(strDestFile) Then
objFSO.DeleteFile strDestFile, True
End If

objTemplateFile.SaveAs strDestFile, xlCSV, , , , , , , , , , True


Next

'В strLogDestFile записывается где будет создан лог-файл и как он будет называться:
strLogDestFile = objFSO.BuildPath(strLogDestFolder, Day(now) & "_" & Month(now) & "_" & Year(now) & ".txt")

'Открытие лог-файла или создание, если его нет:
Set Log = objFSO.OpenTextFile(strLogDestFile, 8, True)
'Запись данных в лог-файл:
Log.Write FormatDateTime(now, 0) 'В лог записывается дата и время обработки файлов
Log.Write ". Обработан файл " & objFSO.GetBaseName(objFile.Name) & "." & objFSO.GetExtensionName(objFile.Name)
Log.Write ". Строк обработано: " & CStr(objSourceFile.Worksheets.Item(1).UsedRange.Rows.Count - 2)
Log.Write ". Чеков создано: " & CStr(objSourceFile.Worksheets.Item(1).UsedRange.Rows.Count - 2)
Log.Write ". Сумма по реестру: " & SumSourceFile
Log.Write ". Сумма по чекам: " & SumDestFile
'Сравнение сумм по реестру и чекам - если они равны, то это записывается в лог
If SumSourceFile = SumDestFile Then
Log.Write ". Суммы равны."
End If
Log.WriteBlankLines(1)
Log.Close

'Обнуление сумм, чтобы для каждого файла реестра и его чеков считалась своя отдельная сумма
SumSourceFile = 0
SumDestFile = 0

objSourceFile.Close False
objTemplateFile.Close False
End Select
Next

If Not objExcel Is Nothing Then
objExcel.Quit
Set objExcel = Nothing


'Копируем файлы из папки "Итог" в папку "Архив"
' Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
' objFSO.CopyFile "C:\Реестр\Итог\*.*" , "C:\Реестр\Архив\"


'Выводит окно о завершении обработки файлов:
WScript.Echo "Чеки сформированы успешно. Обработано " & CountSourceFiles & " реестра на сумму " & SumTotal & ". Подробности на C:\касса"

Else
WScript.Echo "Can't find source folder [" & strSourceFolder & "]."
WScript.Quit 2
End If

Set objFSO = Nothing

Else
WScript.Echo "Can't find template file [" & strTemplateFile & "]."
WScript.Quit 1
End If

'Else
' WScript.Echo "Usage: cscript.exe //nologo """ & WScript.ScriptName & """ <Source folder>"
' WScript.Quit 1

End if
WScript.Quit 0

[megaloman]

jordan_74, Я подробно не разбирался в Вашем коде, понял, что Вы создаёте несколько папок. Потом запутываетесь в путях.
Зачем-то многократно определяете Set objFSO ...

Предлагаю создание папки выделить в отдельную процедуру, при этом при вызове указывать её полный путь

Вот пример применения функции, которая при необходимости создаст все папки в указанном пути, даже если папка более высокого уровня пока не существует

Код:

Option Explicit

Dim strRootFolder
Dim objFSO
Dim strSourceFolder
Dim strRelativeDestFolder
Dim intOut
Dim strFolderDate

strRootFolder = "C:\Реестр"
strSourceFolder = "C:\Реестр\реестр"
strRelativeDestFolder = "C:\Реестр\Итог"
strFolderDate = "C:\Реестр" + "\" + CStr(Year(Date)) + Right(CStr(Month(Date) + 100), 2) + Right(CStr(Day(Date) + 100), 2)

Set objFSO = CreateObject("Scripting.FileSystemObject")

intOut = MakeFold(objFSO, strFolderDate)
intOut = MakeFold(objFSO, strSourceFolder)
intOut = MakeFold(objFSO, strRelativeDestFolder)
intOut = MakeFold(objFSO, strRootFolder)

'----------------------------------------------
Function MakeFold(objFSO, strPathFolder)
    If objFSO.FolderExists(strPathFolder) Then
        MakeFold = 0
        Exit Function
    End If
    
    Dim arrPath
    Dim strPath
    Dim iPath	

    arrPath = Split(strPathFolder, "\")
    strPath = ""
    MakeFold = 1
    
    On Error Resume Next
    For Each iPath In arrPath
        strPath = strPath + iPath + "\"
        If Not objFSO.FolderExists(strPath) Then
            objFSO.CreateFolder strPath
            If Err.Number <> 0 Then
                MsgBox strPath + vbCrLf + vbCrLf + "Error=  " + CStr(Err.Number) + vbCrLf + Err.Description
                MakeFold = 1
                On Error GoTo 0
                Exit Function
            End If
            MakeFold = 0
        End If
    Next
    On Error GoTo 0
End Function

Функцию можно упростить, если последовательно вызывать её для создания папок в иерархии вложенности. В любом случае, чтобы не путаться, предлагаю использовать указание полных путей.

Код:

Option Explicit

Dim strRootFolder
Dim objFSO
Dim strSourceFolder
Dim strRelativeDestFolder
Dim intOut
Dim strFolderDate

strRootFolder = "C:\Реестр"
strSourceFolder = "C:\Реестр\реестр"
strRelativeDestFolder = "C:\Реестр\Итог"
strFolderDate = "C:\Реестр" + "\" + CStr(Year(Date)) + Right(CStr(Month(Date) + 100), 2) + Right(CStr(Day(Date) + 100), 2)

Set objFSO = CreateObject("Scripting.FileSystemObject")

intOut = MakeFold(objFSO, strRootFolder)
intOut = MakeFold(objFSO, strSourceFolder)
intOut = MakeFold(objFSO, strRelativeDestFolder)
intOut = MakeFold(objFSO, strFolderDate)

'----------------------------------------------
Function MakeFold(objFSO, strPathFolder)
    MakeFold = 0
    If Not objFSO.FolderExists(strPathFolder) Then
        On Error Resume Next
        objFSO.CreateFolder strPathFolder
        If Err.Number <> 0 Then
            MsgBox strPathFolder + vbCrLf + vbCrLf + "Error=  " + CStr(Err.Number) + vbCrLf + Err.Description
            MakeFold = 1
        End If
        On Error GoTo 0
    End If
End Function

[jordan_74]

Iska, Добрый день! Спасибо за помощь, все получилось !
Хочу вот о чем спросить, с 2019 года НДС будет не 18 а 20 %. В текущем коде 18% и я понимаю, что нужно задействовать дату. При условии что в реестре дата (второй столбец) больше 31.12.2018 тогда формула расчета НДС будет следующая:
.Range("L3").Value = Fix((anyValue * 20 / 120 + 0.005) * 100) / 100

Просьба помочь в оформлении условия. Вот текущий код

Скрытый текст

Select Case LCase(objFSO.GetExtensionName(objFile.Name))
Case "xls", "xlsx"
If objExcel Is Nothing Then
Set objExcel = WScript.CreateObject("Excel.Application")
End If

objExcel.Workbooks.OpenText strTemplateFile, , , , , , , , , , , , , , , , , True
Set objTemplateFile = objExcel.Workbooks.Item(1)

Set objSourceFile = objExcel.Workbooks.Open(objFile.Path, False, True)

For i = 1 To objSourceFile.Worksheets.Item(1).UsedRange.Rows.Count - 2
With objTemplateFile.Worksheets.Item(1)
anyValue = objSourceFile.Worksheets.Item(1).Cells.Item(i + 1, 4).Value

.Range("B3").Value = anyValue
.Range("F2").Value = anyValue

anyValue = objSourceFile.Worksheets.Item(1).Cells.Item(i + 1, 5).Value

.Range("D3").Value = anyValue
.Range("D4").Value = anyValue
.Range("H3").Value = anyValue
' Подсчет НДС
.Range("L3").Value = Fix((anyValue * 18 / 118 + 0.005) * 100) / 100

'Подсчет общей суммы:
SumTotal = SumTotal + anyValue

'Подсчет суммы по реестру:
SumSourceFile = SumSourceFile + anyValue

'Подсчет суммы по чекам:
SumDestFile = SumDestFile + .Range("H3").Value

End With

[jordan_74]

После проб и ошибок получилось нечто следующее, вроде работает.

Скрытый текст

Select Case LCase(objFSO.GetExtensionName(objFile.Name))
Case "xls", "xlsx"
If objExcel Is Nothing Then
Set objExcel = WScript.CreateObject("Excel.Application")
End If

objExcel.Workbooks.OpenText strTemplateFile, , , , , , , , , , , , , , , , , True
Set objTemplateFile = objExcel.Workbooks.Item(1)

Set objSourceFile = objExcel.Workbooks.Open(objFile.Path, False, True)

For i = 1 To objSourceFile.Worksheets.Item(1).UsedRange.Rows.Count - 2
With objTemplateFile.Worksheets.Item(1)
anyValue = objSourceFile.Worksheets.Item(1).Cells.Item(i + 1, 4).Value

.Range("B3").Value = anyValue
.Range("F2").Value = anyValue

anyValue = objSourceFile.Worksheets.Item(1).Cells.Item(i + 1, 5).Value

.Range("D3").Value = anyValue
.Range("D4").Value = anyValue
.Range("H3").Value = anyValue
' Подсчет НДС
DataPlatez = objSourceFile.Worksheets.Item(1).Cells.Item(i + 1, 2).Value
' Если дата платежа в реестре меньше или равно 31.12.2018
If DataPlatez <= #31/12/2018# Then
' НДС расчитывается по ставке 18%
.Range("L3").Value = Fix((anyValue * 18 / 118 + 0.005) * 100) / 100
Else
' Иначе НДС расчитывается по ставке 20%
.Range("L3").Value = Fix((anyValue * 20 / 120 + 0.005) * 100) / 100
End if

'Подсчет общей суммы:
SumTotal = SumTotal + anyValue

'Подсчет суммы по реестру:
SumSourceFile = SumSourceFile + anyValue

'Подсчет суммы по чекам:
SumDestFile = SumDestFile + .Range("H3").Value

End With