Страницы: 1
RSS
Автоматизированное заполнение карточек учета материалов М-17, Необходимо заполнить около 1000 карточек учета материалов
 
Здравствуйте, может ли кто-то оказать содействие в разъяснении, как можно автоматизировано заполнить около 1000 карточек учета материалов. Есть данные в виде таблицы которые необходимо занести в карточки. Карточки идентичны и методом копирования созданы на отдельных листах в книге с разными порядковыми номерами. В прикрепленных файлах выделил цветом данные которые необходимо занести в карточки.
 
шаблон карточки наберите один раз в Word
используйте "документ слияния" для заполнения (печати) карточек
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Andrey, здравствуйте.
У Вас будет тысяча и один лист в книге?
 
и потом следующая тема:
"а как теперь распечатать эти 1000 заполненных карточек, чтобы не открывать каждый лист и не печатать по одному?"
ответ прежний:
используйте документ слияния
Изменено: Ігор Гончаренко - 20.10.2021 10:32:38
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Этот макрос сохранит карточки в отдельные файлы в папку, в которой находится файл с таблицей и шаблоном.
Код
Option Explicit

Const SHEET_NAME = "Данные таблицы"

Sub СохранитьКарточки()
    Dim wb As Workbook
    Set wb = GetWb1()
    If Not wb Is Nothing Then
        Dim shK As Worksheet
        Dim shD As Worksheet
        Set shD = wb.Sheets(SHEET_NAME)
        Set shK = GetShK(wb)
        If Not shK Is Nothing Then
            SaveCards shD, shK
        End If
    End If
End Sub

Sub SaveCards(shD As Worksheet, shK As Worksheet)
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Dim Application_Calculation As Long
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual

    Dim y As Long
    Dim arr As Variant
    With shD
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = .Range(.Cells(1, 1), .Cells(y, 10))
    End With
    Dim shO As Worksheet
    Dim sFull As String
    Dim sPath As String
    Dim sName As String
    sPath = shD.Parent.Path & "\"
    For y = 2 To UBound(arr, 1)
        Application.StatusBar = y
        If arr(y, 2) <> "" Then
            shK.Copy
            Set shO = ActiveSheet
            
            With shO
                .Name = "Карточка " & y - 1
                .Range("BA5").Value = y - 1
                .Range("P18").Value = arr(y, 1)
                .Range("BD16").Value = arr(y, 2)
                .Range("AA34").Value = arr(y, 3)
                .Range("BV16").Value = arr(y, 4)
                .Range("BP16").Value = arr(y, 5)
                .Range("BJ16").Value = arr(y, 6)
                .Range("BJ34").Value = arr(y, 7)
                .Range("CD34").Value = arr(y, 8)
                .Range("A34").Value = arr(y, 9)
                .Range("I34").Value = arr(y, 10)
            End With
            
            sName = arr(y, 2) & ".xlsx"
            sFull = sPath & sName
            
            On Error Resume Next
            Workbooks(sName).Close
            Kill sFull
            On Error GoTo 0
            
            With shO.Parent
                .SaveAs Filename:=sFull, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
                .Close False
            End With
        End If
    Next
    Application.StatusBar = False
    Application.Calculation = Application_Calculation
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
End Sub

Function GetShK(wb As Workbook) As Worksheet
    Dim sh As Worksheet
    For Each sh In wb.Worksheets
        If Left(sh.Name, Len("Карточка")) = "Карточка" Then
            Set GetShK = sh
            Exit Function
        End If
    Next
End Function

Function GetWb1() As Workbook
    Dim wb As Workbook
    Set wb = ActiveWorkbook
    On Error Resume Next
    With wb.Sheets(SHEET_NAME): End With
    If Err = 0 Then
        Set GetWb1 = wb
        Exit Function
    End If
        
    For Each wb In Application.Workbooks
        Err.Clear
        With wb.Sheets(SHEET_NAME): End With
        If Err = 0 Then
            Set GetWb1 = wb
            Exit Function
        End If
    Next
    On Error GoTo 0
End Function
 
А для чего вообще сохранять карточки, достаточно просто заполнять шаблон по необходимости, а все данные хранятся в таблице
 
Карточка складского учета материалов ведется материально-ответственным лицом (например, кладовщиком) отдельно по каждому номенклатурному номеру материала на основании первичных приходно-расходных документов в день совершения операции. Материальное лицо карточки не вел,  теперь их срочно  нужно сделать. Материалов больше 1000 наименований и на каждый материал отдельная карточка  
 
Так Вам об этом и пишут. Таблица с "провтыками" материально-ответственного лица + один лист-шаблон (или шаблон в  Word)
Макрос пробегает по таблице. Берет одну запись, вставляет данные в М-17, печатает. Берет вторую запись... А Вы в это время кофе пьете или пасьянс раскладываете )
 
Все понял, спасибо большое  
 
МатросНаЗебре,Добрый день,спасибо большое за макрос,очень облегчили работу. Хотел попросить немного изменить его если возможно!В списке с данными встречаются материалы с одинаковым номенклатурным номером,но с разными датами поступления и  с разными номерами документа. Написанный Вами макрос создает карточку только с первым попавшимся из списка материалом с одинаковым номером.Можно ли сделать так чтобы в карточку заносились все материалы с одинаковыми номенклатурными номерами из списка в отдельные строки ,и учитывался приход, расход и остаток в последней строке суммировался!?.Если не получится так сделать,ничего страшного и за то что уже сделали огромное спасибо!!!
Изменено: Andrey - 22.10.2021 13:13:41
 
Не нужно создавать сообщение для файла, можно дополнить предыдущее
Изменено: vikttur - 21.10.2021 16:23:12
 
Код
Option Explicit
'2
Const SHEET_NAME = "Данные таблицы"
 
Sub СохранитьКарточки()
    Dim wb As Workbook
    Set wb = GetWb1()
    If Not wb Is Nothing Then
        Dim shK As Worksheet
        Dim shD As Worksheet
        Set shD = wb.Sheets(SHEET_NAME)
        Set shK = GetShK(wb)
        If Not shK Is Nothing Then
            SaveCards shD, shK
        End If
    End If
End Sub
 
Sub SaveCards(shD As Worksheet, shK As Worksheet)
    Application.ScreenUpdating = False
    Application.EnableEvents = False
     
    Dim Application_Calculation As Long
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim y As Long
    Dim u As Long
    Dim arr As Variant
    With shD
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = .Range(.Cells(1, 1), .Cells(y, 10))
    End With
    
    Dim wb As Workbook
    Dim shO As Worksheet
    Dim sFull As String
    Dim sPath As String
    Dim sName As String
    sPath = shD.Parent.Path & "\"
    For y = 2 To UBound(arr, 1)
        Application.StatusBar = y
        If arr(y, 2) <> "" Then
            
            sName = arr(y, 2) & ".xlsx"
            sFull = sPath & sName
            
            On Error Resume Next
            Workbooks(sName).Close False
            On Error GoTo 0
            
            If fso.FileExists(sFull) Then
                Set wb = Workbooks.Open(sFull)
                Set shO = wb.Sheets(1)
            Else
                shK.Copy
                Set shO = ActiveSheet
                Set wb = shO.Parent
                wb.SaveAs Filename:=sFull, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
                
                With shO
                    .Name = "Карточка " & y - 1
                    .Range("BA5").Value = y - 1
                    .Range("P18").Value = arr(y, 1)
                    .Range("BD16").Value = arr(y, 2)
                    .Range("BV16").Value = arr(y, 4)
                    .Range("BP16").Value = arr(y, 5)
                    .Range("BJ16").Value = arr(y, 6)
                    .Range("A34").MergeArea.ClearContents
                    .Range("I34").MergeArea.ClearContents
                End With
            End If
             
            With shO
                If WorksheetFunction.CountIfs(.Columns("I:I"), arr(y, 10)) = 0 Then
                    u = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
                    .Cells(u, "BJ").Value = arr(y, 7)
                    .Cells(u, "CD").Value = arr(y, 8)
                    .Cells(u, "A").NumberFormat = "dd/mm/yyyy"
                    .Cells(u, "A").Value = arr(y, 9)
                    .Cells(u, "I").Value = arr(y, 10)
                    .Cells(u, "AA").Value = arr(y, 3)
                    .Cells(u, "R").Value = "-"
                    .Cells(u, "AX").Value = "-"
                    .Cells(u, "BT").Value = "-"
                    .Cells(u + 1, "BJ").FormulaR1C1 = "=SUM(R34C:R[-1]C)"
                    .Cells(u + 1, "CD").FormulaR1C1 = "=SUM(R34C:R[-1]C)"
                End If
            End With
            wb.Close True

'            On Error Resume Next
'            Workbooks(sName).Close
'            Kill sFull
'            On Error GoTo 0
             
'            With shO.Parent
'                .SaveAs Filename:=sFull, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
'                .Close False
'            End With
        End If
    Next
    Application.StatusBar = False
    Application.Calculation = Application_Calculation
    Application.ScreenUpdating = True
    Application.EnableEvents = True
     
End Sub
 
Function GetShK(wb As Workbook) As Worksheet
    Dim sh As Worksheet
    For Each sh In wb.Worksheets
        If Left(sh.Name, Len("Карточка")) = "Карточка" Then
            Set GetShK = sh
            Exit Function
        End If
    Next
End Function
 
Function GetWb1() As Workbook
    Dim wb As Workbook
    Set wb = ActiveWorkbook
    On Error Resume Next
    With wb.Sheets(SHEET_NAME): End With
    If Err = 0 Then
        Set GetWb1 = wb
        Exit Function
    End If
         
    For Each wb In Application.Workbooks
        Err.Clear
        With wb.Sheets(SHEET_NAME): End With
        If Err = 0 Then
            Set GetWb1 = wb
            Exit Function
        End If
    Next
    On Error GoTo 0
End Function
 
МатросНаЗебре,Добрый день, с последним макросом карточки выгдят вот так::
Изменено: Andrey - 22.10.2021 13:27:58
 
Количество столбцов в "как должны быть" отличается от количества столбцов в сообщении #1.
Код
Option Explicit
'3
Const SHEET_NAME = "Данные таблицы"
  
Sub СохранитьКарточки()
    Dim wb As Workbook
    Set wb = GetWb1()
    If Not wb Is Nothing Then
        Dim shK As Worksheet
        Dim shD As Worksheet
        Set shD = wb.Sheets(SHEET_NAME)
        Set shK = GetShK(wb)
        If Not shK Is Nothing Then
            SaveCards shD, shK
        End If
    End If
End Sub
  
Sub SaveCards(shD As Worksheet, shK As Worksheet)
    Application.ScreenUpdating = False
    Application.EnableEvents = False
      
    Dim Application_Calculation As Long
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
     
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
     
    Dim y As Long
    Dim u As Long
    Dim arr As Variant
    With shD
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = .Range(.Cells(1, 1), .Cells(y, 11))
    End With
     
    Dim wb As Workbook
    Dim shO As Worksheet
    Dim sFull As String
    Dim sPath As String
    Dim sName As String
    sPath = shD.Parent.Path & "\"
    For y = 2 To UBound(arr, 1)
        Application.StatusBar = y
        If arr(y, 2) <> "" Then
             
            sName = arr(y, 2) & ".xlsx"
            sFull = sPath & sName
             
            On Error Resume Next
            Workbooks(sName).Close False
            On Error GoTo 0
             
            If fso.FileExists(sFull) Then
                Set wb = Workbooks.Open(sFull)
                Set shO = wb.Sheets(1)
            Else
                shK.Copy
                Set shO = ActiveSheet
                Set wb = shO.Parent
                wb.SaveAs Filename:=sFull, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
                 
                With shO
                    .Name = "Карточка " & y - 1
                    .Range("BA5").Value = y - 1
                    .Range("P18").Value = arr(y, 1)
                    .Range("BD16").Value = arr(y, 2)
                    .Range("BV16").Value = arr(y, 4)
                    .Range("BP16").Value = arr(y, 5)
                    .Range("BJ16").Value = arr(y, 6)
                    .Range("A34").Resize(10, 17).ClearContents
                    '.Range("I34").MergeArea.ClearContents
                End With
            End If
              
            With shO
                If WorksheetFunction.CountIfs(.Columns("I:I"), arr(y, 10)) = 0 Then
                    u = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
                    .Cells(u, "BJ").Value = arr(y, 7)
                    .Cells(u, "CD").Value = arr(y, 8)
                    .Cells(u, "BT").Value = arr(y, 9)
                    .Cells(u, "A").NumberFormat = "dd/mm/yyyy"
                    .Cells(u, "A").Value = arr(y, 10)
                    .Cells(u, "I").Value = arr(y, 11)
                    .Cells(u, "AA").Value = arr(y, 3)
                    .Cells(u, "R").Value = "-"
                    .Cells(u, "AX").Value = "-"
                    .Cells(u, "BT").Value = "-"
'                    .Cells(u + 1, "BJ").FormulaR1C1 = "=SUM(R34C:R[-1]C)"
'                    .Cells(u + 1, "CD").FormulaR1C1 = "=SUM(R34C:R[-1]C)"
                End If
            End With
            wb.Close True
 
'            On Error Resume Next
'            Workbooks(sName).Close
'            Kill sFull
'            On Error GoTo 0
              
'            With shO.Parent
'                .SaveAs Filename:=sFull, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
'                .Close False
'            End With
        End If
    Next
    Application.StatusBar = False
    Application.Calculation = Application_Calculation
    Application.ScreenUpdating = True
    Application.EnableEvents = True
      
End Sub
  
Function GetShK(wb As Workbook) As Worksheet
    Dim sh As Worksheet
    For Each sh In wb.Worksheets
        If Left(sh.Name, Len("Карточка")) = "Карточка" Then
            Set GetShK = sh
            Exit Function
        End If
    Next
End Function
  
Function GetWb1() As Workbook
    Dim wb As Workbook
    Set wb = ActiveWorkbook
    On Error Resume Next
    With wb.Sheets(SHEET_NAME): End With
    If Err = 0 Then
        Set GetWb1 = wb
        Exit Function
    End If
          
    For Each wb In Application.Workbooks
        Err.Clear
        With wb.Sheets(SHEET_NAME): End With
        If Err = 0 Then
            Set GetWb1 = wb
            Exit Function
        End If
    Next
    On Error GoTo 0
End Function
 
МатросНаЗебре,Макрос не возможно применить,ругается  
 
Переключите раскладку на РУС при копировании кода с форума в файл.
 
Цитата
шаблон карточки наберите один раз в Word
используйте "документ слияния" для заполнения (печати) карточек
Поддерживаю. В данном случае есть инструмент Word, не надо изобретать велосипед.
Страницы: 1
Наверх