Sub Kniga()
Dim WB1 As Workbook
Dim WB2 As Workbook
Dim Path1 As String, key As String
Dim i As Long, i_n As Long, i_n2 As Long
Dim Num As Object
Dim k As Long, WB2C As Long
Dim WCel1 As Single, WCel2 As Single
Set WB1 = ActiveWorkbook
Set Num = CreateObject("Scripting.dictionary")
Path1 = WB1.Path & "\"
i_n = WB1.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
WCel1 = WB1.Worksheets(1).Cells(1, 1).ColumnWidth
WCel2 = WB1.Worksheets(1).Cells(1, 2).ColumnWidth
Workbooks.Add
Set WB2 = ActiveWorkbook
WB2C = WB2.Worksheets.Count
For i = 2 To i_n
  key = WB1.Worksheets(1).Cells(i, 2)
   If Not Num.exists(key) Then
      Num.Add key, WB1.Worksheets(1).Cells(i, 1)
      If k < WB2C Then
         k = k + 1
         WB2.Worksheets(k).Name = key
      Else
         WB2.Worksheets.Add(After:=Worksheets(WB2.Worksheets.Count)).Name = key
      End If
         WB1.Worksheets(1).Cells(1, 1).Resize(, 3).Copy WB2.Worksheets(key).Cells(1, 1)
         WB1.Worksheets(1).Cells(i, 1).Resize(, 3).Copy WB2.Worksheets(key).Cells(2, 1)
    Else
      i_n2 = WB2.Worksheets(key).Cells(Rows.Count, 1).End(xlUp).Row
      WB1.Worksheets(1).Cells(i, 1).Resize(, 3).Copy WB2.Worksheets(key).Cells(i_n2 + 1, 1)
      WB1.Worksheets(1).Cells(i, 1).Resize(, 3).Copy WB2.Worksheets(key).Cells(i_n2 + 1, 1)
   End If
Next i
For i = 1 To WB2.Worksheets.Count
  WB2.Worksheets(i).Columns(1).ColumnWidth = WCel1
  WB2.Worksheets(i).Columns(2).ColumnWidth = WCel2
Next i
WB2.SaveAs Path1 & "По складам.xlsx"

End Sub

Sub Kniga()
Dim WB1 As Workbook
Dim WB2 As Workbook
Dim Path1 As String, key As String
Dim i As Long, i_n As Long, i_n2 As Long
Dim Num As Object
Dim k As Long, WB2C As Long
Dim WCel1 As Single, WCel2 As Single, WCel3 As Single 'переменная WCel3 (ширина 3-го столбца)
Set WB1 = ActiveWorkbook
Set Num = CreateObject("Scripting.dictionary")
Path1 = WB1.Path & "\"
i_n = WB1.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
WCel1 = WB1.Worksheets(1).Cells(1, 1).ColumnWidth
WCel2 = WB1.Worksheets(1).Cells(1, 2).ColumnWidth
'запоминаем ширину 3-го столбца
WCel3 = WB1.Worksheets(1).Cells(1, 3).ColumnWidth
Workbooks.Add
Set WB2 = ActiveWorkbook
WB2C = WB2.Worksheets.Count
For i = 2 To i_n
  key = WB1.Worksheets(1).Cells(i, 2)
   If Not Num.exists(key) Then
      Num.Add key, WB1.Worksheets(1).Cells(i, 1)
      If k < WB2C Then
         k = k + 1
         WB2.Worksheets(k).Name = key
      Else
         WB2.Worksheets.Add(After:=Worksheets(WB2.Worksheets.Count)).Name = key
      End If
         'копируем диапазон ИЗ 3 ЯЧЕЕК
         WB1.Worksheets(1).Cells(1, 1).Resize(, 3).Copy WB2.Worksheets(key).Cells(1, 1)
         WB1.Worksheets(1).Cells(i, 1).Resize(, 3).Copy WB2.Worksheets(key).Cells(2, 1)
    Else
      i_n2 = WB2.Worksheets(key).Cells(Rows.Count, 1).End(xlUp).Row
      WB1.Worksheets(1).Cells(i, 1).Resize(, 3).Copy WB2.Worksheets(key).Cells(i_n2 + 1, 1)
   End If
Next i
For i = 1 To WB2.Worksheets.Count
  WB2.Worksheets(i).Columns(1).ColumnWidth = WCel1
  WB2.Worksheets(i).Columns(2).ColumnWidth = WCel2
  'устанавливаем ширину 3-го столбца
  WB2.Worksheets(i).Columns(3).ColumnWidth = WCel3
Next i
WB2.SaveAs Path1 & "По складам.xlsx"
End Sub