Public Sub Перенос2()
Dim m As Range
Dim m1 As Variant
Dim i As Long
Dim j As Long
Dim a As String
Dim b As String
Dim s As String

    Sheets("1.БД_анализ").Select
    Set m = Range(Cells(2, 1).Address, Cells(Application.WorksheetFunction.CountA(Columns(2)), 2).Address)
        m1 = m.Value
    Sheets("5.Код_дата").Select
    Cells().Select
    Selection.ClearContents
    Cells(1, 1).Select
    For i = 1 To m.Rows.Count
        a = m1(i, 1)
        b = m1(i, 2)
       For j = 1 To Len(b)
            If Mid(b, j, 1) = ";" Then
               With ActiveCell
                 .Value = a
                 .Offset(0, 1).Value = s
                 .Offset(1, 0).Select
               End With
               s = ""
            Else
            s = s + Mid(b, j, 1)
            End If
      Next
    Next
End Sub

Sub Остатки_Реверс()
Application.ScreenUpdating = False
Sheets.Add
ActiveSheet.Name = "Остатки"
Range("A1").Select
'With ActiveCell
' .Value = "Дата"
' .Offset(0, 1).Value = "Владелец"
 '.Offset(0, 2).Value = "Место хранения"
' .Offset(0, 2).Value = "Номенклатура.Код"
' .Offset(0, 3).Value = "Количество Начальный остаток"
' .Offset(0, 4).Value = "Себестоимость Начальный остаток"
' .Offset(1, 0).Select
' End With

'Sheets("Готовый лист").Select
'Range("A2:F10000").ClearContents
'Range("A2").Select
Sheets("TDSheet").Select
    Cells.Select
    Selection.Copy
    Sheets("Остатки").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Selection.Rows.Ungroup
Dim r As Range
Dim r1 As Variant
Dim a As Long
Dim i As Long
Dim b As String
'Sheets("TDSheet").Select
  Range("A1").Select
 ActiveCell.SpecialCells(xlLastCell).Select
 a = ActiveCell.Row

'a = Application.WorksheetFunction.CountA(Columns(2))
Range("A1").Select
Set r = Range(Cells(2, 1), Cells(a, 5))
r1 = r.Value
Sheets("Остатки").Select
For i = 1 To a - 2
  If i = 1 Then
    r1(i, 1) = Left(r1(i, 1), 10)
    b = r1(i, 1)
  Else
     If r1(i, 1) = 0 Then
        r1(i, 1) = b
     Else
        r1(i, 1) = Left(r1(i, 1), 10)
        b = r1(i, 1)
     End If
    
  End If
Next
r.Value = r1

'  With ActiveCell
'     .Value = r1(i, 1)
'     .Offset(0, 1).Value = r1(i, 2)
'     .Offset(0, 2).Value = r1(i, 4)
'     .Offset(0, 3).Value = r1(i, 5)
'     .Offset(0, 4).Value = r1(i, 6)
'     '.Offset(0, 5).Value = r1(i, 4)
'     .Offset(1, 0).Select
'  End With
'
'Next

Range("B2").Select
For i = 1 To a - 1
    If ActiveCell.Value = "" Then
        Rows(ActiveCell.Row).Delete
    Else
        If ActiveCell.Value = "Распределительный центр" Then
            If ActiveCell.Offset(0, 1).Value = "Склад 15 (брак)" Then
              ActiveCell.Value = "Склад 15 (брак)"
            Else
            End If
        Else
        End If
        ActiveCell.Offset(1, 0).Select
    End If
Next
Columns(3).Delete
    Columns("A:A").Select
    Selection.NumberFormat = "m/d/yyyy"
Range("A1").Select
Application.ScreenUpdating = True

End Sub

Sub ДАТА()
Set ddd = Columns(1).SpecialCells(xlCellTypeConstants)
For Each x In ddd
'If IsDate(x) Then x.Value = CDate(x)
x.Value = CDate(x)
Next
End Sub