не нашел нужной категории для проекта, неужели в нем так мало программируют? ну да и ладно задача такая, нужно пройтись по списку задач в Проекте и в графе Длительность и расставить строку "0м" - типа 0 минут. У Задач которые включают в себя подзадачи нельзя изменить значение длительности, вопрос, как посмотреть в VBA можно вводить значение в ячейку или нет.
задача такая, нужно пройтись по списку задач в Проекте и в графе время расставить 0м. у Задач которые включают в себя подзадачи нельзя изменить значение длительности, вопрос, как посмотреть в VBA можно вводить значение в ячейку или нет.
для удобства уберу лишний код тогда файлы для сканирования какие то слишком "тяжелые" поэтому на диск скинул https://drive.google.com/folderview?id=0ByCliqqf00OwbGFCQkpSNmRlVTQ&usp=sharing
тыкаю в ячейку, допустим в 4,3 у меня название спецификации. вылетает - завершается процедура ScanP с параметром в виде объекта(пробывал и с книгой workbook через workbooks.open), которая вызывается из ОткрытиеПапкиПОКРАСКА
я пошаговой смотрел, msgbox .cells(4,3) пробывал и другие ячейки пытался вывести, просто кудв не "ткни" в книгу вылетает. такое может быть из за модуля и формы внутри ее?
Option Base 1 ' определение данных для сканирования Public Type Inf56Spec namespec As String nProg As String nRep As String time As String material As String tolshina As String list As String ostList As String End Type
Public Type InfGSpec namespec As String time As String End Type
Public Type InfPSpec namespec As String time As String raschod As String End Type
Public Type InfZak namezak As String tokarka As String sv As String sl As String shina As String End Type
Public Type Specification namespec As String End Type
' определение глобальных массивов с данными Dim Info5Spec() As Inf56Spec Dim Info6Spec() As Inf56Spec Dim InfoGSpec() As InfGSpec Dim InfoPSpec() As InfoPok Dim InfoZak() As InfZak Dim Spec() As Specification
'указание количества для каждого массива Dim kInfo5Spec As Integer Dim kInfo6Spec As Integer Dim kInfoGSpec As Integer Dim kInfoPSpec As Integer Dim kInfoZak As Integer Dim kSpec As Integer
Sub ScanZak(zakbook As Workbook)
Dim iFirst As Long Dim iLast As Long iFirst = 1224 iLast = 1280 Dim i As Long Dim k As Integer With zakbook.Sheets(1) For i = iFirst To iLast If .Cells(i, 1).Text <> "" Then kInfoZak = kInfoZak + 1 ReDim Preserve InfoZak(kInfoZak) On Error Resume Next InfoZak(kInfoZak).namezak = .Cells(i, 1).Text On Error Resume Next InfoZak(kInfoZak).tokarka = .Cells(i, 9).Text On Error Resume Next InfoZak(kInfoZak).shina = .Cells(i, 13).Text On Error Resume Next InfoZak(kInfoZak).sv = Left(.Cells(i, 10).Text, InStr(.Cells(i, 10).Text, "/") - 1) On Error Resume Next InfoZak(kInfoZak).sl = Mid(.Cells(i, 10).Text, InStr(.Cells(i, 10).Text, "/") + 1, Len(.Cells(i, 10).Text) - InStr(.Cells(i, 10).Text, "/"))
End If Next i End With
End Sub
Sub ScanSpec5(bookspec As Workbook)
kInfo5Spec = kInfo5Spec + 1 ReDim Preserve Info5Spec(kInfo5Spec) Info5Spec(kInfo5Spec).namespec = "TC-500 " & bookspec.Sheets(1).Cells(7, 10).Text Info5Spec(kInfo5Spec).nProg = bookspec.Sheets(1).Cells(7, 1).Text Info5Spec(kInfo5Spec).nRep = bookspec.Sheets(1).Cells(7, 2).Text Info5Spec(kInfo5Spec).time = bookspec.Sheets(1).Cells(7, 8).Text Dim k As Integer Dim mat As String k = 14 Do While bookspec.Sheets(1).Cells(k, 1) <> "Материал" Or k >= 9 If bookspec.Sheets(1).Cells(k, 1) <> "" Then mat = bookspec.Sheets(1).Cells(k, 1).Text Exit Do End If k = k - 1 Loop Dim q As Integer
q = InStr(mat, "s") If q = 0 Then q = InStr(mat, "S") End If If q = 0 Then Info5Spec(kInfo5Spec).tolshina = "" Info5Spec(kInfo5Spec).material = mat Else Info5Spec(kInfo5Spec).tolshina = Mid(mat, q, Len(mat) - q + 1) Info5Spec(kInfo5Spec).material = Mid(mat, 1, q - 1) End If Info5Spec(kInfo5Spec).list = bookspec.Sheets(1).Cells(k, 4).Text Info5Spec(kInfo5Spec).ostList = bookspec.Sheets(1).Cells(k, 6).Text
End Sub
Sub ScanSpec6(bookspec As Workbook)
kInfo6Spec = kInfo6Spec + 1 ReDim Preserve Info6Spec(kInfo6Spec) Info6Spec(kInfo6Spec).namespec = "TC-600 " & bookspec.Sheets(1).Cells(7, 10).Text Info6Spec(kInfo6Spec).nProg = bookspec.Sheets(1).Cells(7, 1).Text Info6Spec(kInfo6Spec).nRep = bookspec.Sheets(1).Cells(7, 2).Text Info6Spec(kInfo6Spec).time = bookspec.Sheets(1).Cells(7, 8).Text Dim k As Integer Dim mat As String k = 14 Do While bookspec.Sheets(1).Cells(k, 1) <> "Материал" Or k >= 9 If bookspec.Sheets(1).Cells(k, 1) <> "" Then mat = bookspec.Sheets(1).Cells(k, 1).Text Exit Do End If k = k - 1 Loop Dim q As Integer
q = InStr(mat, "s") If q = 0 Then q = InStr(mat, "S") End If If q = 0 Then Info6Spec(kInfo6Spec).tolshina = "" Info6Spec(kInfo6Spec).material = mat Else Info6Spec(kInfo6Spec).tolshina = Mid(mat, q, Len(mat) - q + 1) Info6Spec(kInfo6Spec).material = Mid(mat, 1, q - 1) End If
kInfoGSpec = kInfoGSpec + 1 ReDim Preserve InfoGSpec(kInfoGSpec) With bookspec.Sheets("Спецификация с гибки") InfoGSpec(kInfoGSpec).namespec = "Гиб. " & .Cells(5, 4).Text Dim k As Integer k = 1 Do While InStr(.Cells(k, 1), "ИТОГО") = 0 And k < 150 k = k + 1 Loop InfoGSpec(kInfoGSpec).time = .Cells(k, 6).Text End With End Sub
Sub ScanP(bookspec As Workbook)
With bookspec.Worksheets(1)
'тут ошибка
If .Cells(4, 3).Value <> Null Then kInfoPSpec = kInfoPSpec + 1 ReDim Preserve InfoPSpec(kInfoPSpec) InfoPSpec(kInfoPSpec).namezak = "Покр. " & .Cells(4, 3).Text Dim NN As Integer NN = InStr(InfoPSpec(kInfoPSpec).namezak, "№") InfoPSpec(kInfoPSpec).namezak = WorksheetFunction.Trim(Mid(InfoPSpec(kInfoPSpec).namezak, NN + 1, Len(InfoPSpec(kInfoPSpec).namezak) - NN))
Dim Itogo As Double Dim ItogoKras As Double
Dim summ As Double
Dim RowItog As Integer Dim ColumnItog As Integer Dim k As Integer Dim i As Integer k = 200 For i = 10 To k If InStr(StrConv(.Cells(i, 40).Text, vbProperCase), "Итог") <> 0 Then ColumnItog = 40 RowItog = i i = k GoTo найден End If Next i
For i = 10 To k
On Error GoTo err1: summ = summ + CDbl(.Cells(i, 41).Value)
err1: If InStr(StrConv(.Cells(i, 41).Text, vbProperCase), "Итог") <> 0 Then ColumnItog = 41 RowItog = i i = k GoTo найден End If Next i найден:
If ColumnItog = 40 Then Itogo = .Cells(RowItog, ColumnItog + 2).Value ItogoKras = .Cells(RowItog, ColumnItog + 1).Value GoTo далеезаполнение End If
If ColumnItog = 41 Then Itogo = summ ItogoKras = .Cells(RowItog, ColumnItog + 1).Value GoTo далеезаполнение End If
InfoPSpec(kInfoPSpec).time = CStr(Itogo) End If End With End Sub
Sub ВыборСпецификаций(PathToFolder As String) Dim specbook As Workbook Dim FSO 'открытие заказов Set FSO = CreateObject("Scripting.FileSystemObject") Dim file Set SubFolder = FSO.getfolder(PathToFolder) For Each f1 In SubFolder.subfolders kSpec = kSpec + 1 ReDim Preserve Spec(kSpec) Spec(kSpec).namespec = f1.Name Next End Sub
Sub ОткрытиеПапкиПОКРАСКА(PathToFolder As String) Dim specbook As Workbook Dim FSO 'открытие заказов Set FSO = CreateObject("Scripting.FileSystemObject") Dim file
'Set SubFolder = FSO.getfolder(PathToFolder) 'For Each f1 In SubFolder.subfolders ' On Error Resume Next: Set file = FSO.getfolder(f1.Name) ' If Not file Is noting Then ' For Each sfile In file.Files ' If InStr(sfile.Name, "окрас") <> 0 Then ' ' Set specbook = Workbooks.Open(file.Name & "\" & sfile.Name, ReadOnly:=True) ' СохранениеБезМакросов specbook, file.Name & "\" ' specbook.Close False ' End If ' Next ' End If 'Next
Set SubFolder = FSO.getfolder(PathToFolder) For Each f1 In SubFolder.subfolders On Error Resume Next: Set file = FSO.getfolder(f1.Name) If Not file Is noting Then For Each sfile In file.Files If InStr(sfile.Name, "окрас") <> 0 And InStr(sfile.Name, "без макросов") <> 0 Then
Set specbook = GetObject(file.Name & "\" & sfile.Name) 'Workbooks.Open(file.Name & "\" & sfile.Name, ReadOnly:=True) ScanP specbook specbook.Close False End If Next End If Next End Sub
Sub ОткрытиеПапкиГИБКА(PathToFolder As String) Dim specbook As Workbook Dim FSO 'открытие заказов Set FSO = CreateObject("Scripting.FileSystemObject") Dim file Set SubFolder = FSO.getfolder(PathToFolder) For Each f1 In SubFolder.subfolders On Error Resume Next: Set file = FSO.getfolder(f1.Name) If Not file Is noting Then For Each sfile In file.Files If InStr(sfile.Name, "ибк") <> 0 Then
Set specbook = GetObject(file.Name & "\" & sfile.Name) 'Workbooks.Open(file.Name & "\" & sfile.Name, ReadOnly:=True) ScanG specbook specbook.Close False End If Next End If Next End Sub
Sub ОткрытиеПапки600(PathToFolder As String) Dim specbook As Workbook Dim FSO 'открытие заказов Set FSO = CreateObject("Scripting.FileSystemObject") Dim file Set SubFolder = FSO.getfolder(PathToFolder) For Each f1 In SubFolder.subfolders On Error Resume Next: Set file = FSO.getfolder(f1.Name) If Not file Is noting Then For Each sfile In file.Files If InStr(sfile.Name, "66") = 1 Then
Set specbook = GetObject(file.Name & "\" & sfile.Name) 'Workbooks.Open(file.Name & "\" & sfile.Name, ReadOnly:=True) ScanSpec6 specbook specbook.Close False End If Next End If Next End Sub
Sub ОткрытиеПапки500(PathToFolder As String) Dim specbook As Workbook Dim FSO 'открытие заказов Set FSO = CreateObject("Scripting.FileSystemObject") Dim file Set SubFolder = FSO.getfolder(PathToFolder) For Each f1 In SubFolder.subfolders On Error Resume Next: Set file = FSO.getfolder(f1.Name) If Not file Is noting Then For Each sfile In file.Files If InStr(sfile.Name, "55") = 1 Then
Set specbook = GetObject(file.Name & "\" & sfile.Name) 'Workbooks.Open(file.Name & "\" & sfile.Name, ReadOnly:=True) ScanSpec5 specbook specbook.Close False End If Next End If Next End Sub
Sub ОткрытиеПапкиЗАКАЗЫ(PathToFolder As String) Dim zakbook As Workbook Dim FSO 'открытие заказов Set FSO = CreateObject("Scripting.FileSystemObject") Dim file On Error Resume Next: Set file = FSO.getfolder(PathToFolder) If Not file Is noting Then For Each sfile In file.Files If InStr(sfile.Name, "Заказы") <> 0 Then
Set zakbook = GetObject(PathToFolder & sfile.Name) 'Workbooks.Open(PathToFolder & sfile.Name, ReadOnly:=True) ScanZak zakbook zakbook.Close False End If Next End If End Sub
Sub ОткрытиеПапок() Prepare УдалениеИнформации
Dim ZakPathToFolder As String Dim OpenFolderZak As FileDialog Set OpenFolderZak = Application.FileDialog(msoFileDialogFolderPicker) With OpenFolderZak .Title = "Открытие папки с заказом" If .Show = 0 Then Exit Sub ZakPathToFolder = .SelectedItems(1) & "\" End With
ОткрытиеПапкиЗАКАЗЫ ZakPathToFolder
Dim SpecPathToFolder As String Dim OpenFolderSpec As FileDialog Set OpenFolderSpec = Application.FileDialog(msoFileDialogFolderPicker) With OpenFolderSpec .Title = "Открытие папки со Спецификациями" If .Show = 0 Then Exit Sub SpecPathToFolder = .SelectedItems(1) & "\" End With
Sub СохранениеБезМакросов(book As Workbook, path As String) book.SaveAs path & book.Name & "(без макросов).xlsx", FileFormat:=xlOpenXMLWorkbook End Sub
Sub Заполнение() Dim AcRow As Integer Dim iSpec As Integer Dim i500 As Integer Dim i600 As Integer Dim iGib As Integer Dim iPok As Integer Dim iZak As Integer
AcRow = 2 With ThisWorkbook.Sheets("база данных") Do While iSpec < UBound(Spec) iSpec = iSpec + 1 .Cells(AcRow, 2) = Spec(iSpec).namespec 'сравниваются по номеру спецификации
в общем, дело такое. нужно из папки с файлами выбрать файлы по имени, открыть их и достать из них нужную ифу. знаю что и где в них находится, то есть обращение к несуществующим ячейкам не происходит. видов файлов всего 4. 4 вида открываются, все норм. 3 вида сканируются, а вот 1 вид при обращении к ячейке завершает процедуру и никаких ошибок ни каких предупреждений, просто завершает. помогите разобраться в чем дело. код(весь код не вижу смысла писать, но если что могу написать):
Код: (vb)
Sub ScanP(bookspec As Workbook)
With bookspec.Worksheets(1) If .Cells(4, 3) <> Null Then kInfoPSpec = kInfoPSpec + 1 ReDim Preserve InfoPSpec(kInfoPSpec)
Просмотр сообщений
