2017-02-23 113 views
0

Данные выглядит следующим образомVBA - Для того, чтобы разделить и преуспевать файл на несколько файлов и разделить эти файлы на несколько листов

https://i.stack.imgur.com/oWzNK.jpg

Мне нужно разделить эти данные на двух уровнях

  1. Разделите данные на разные книги на основе первой буквы кода продукта (столбец C), например A.xlsx, B.xlsx и т. Д., Которые будут содержать данные, относящиеся только к этим письмам

  2. Разделите данные в указанных выше книгах на рабочие листы на основе уникального кода продукта, например. C.xlsx будет иметь листы с именем C02, C021, и эти листы будут содержать данные, относящиеся к коду procut.

Как их можно объединить в одном коде VBA?

У меня есть следующий код, чтобы разделить данные на листы по коду продукта:


    Sub split_data() 
    Dim lr As Long 
    Dim ws As Worksheet 
    Dim vcol, i As Integer 
    Dim icol As Long 
    Dim myarr As Variant 
    Dim title As String 
    Dim titlerow As Integer 
    vcol = 3 
    Set ws = Sheets("Sales Data") 
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row 
    title = "A1:H1" 
    titlerow = ws.Range(title).Cells(1).Row 
    icol = ws.Columns.Count 
    ws.Cells(1, icol) = "Unique" 
    For i = 2 To lr 
    On Error Resume Next 
    If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then 
    ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol) 
    End If 
    Next 
    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants)) 
    ws.Columns(icol).Clear 
    For i = 2 To UBound(myarr) 
    ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & "" 
    If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then 
    Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & "" 
    Else 
    Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count) 
    End If 
    ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1") 
    Sheets(myarr(i) & "").Columns.AutoFit 
    Next 
    ws.AutoFilterMode = False 
    ws.Activate

End Sub 

Но теперь мне нужно, чтобы объединить все листы, начиная с А в книге " A.xlsx "и аналогичным образом для B, C и D. Нужна помощь в этом

+0

Не могли бы вы включить ваши данные в виде текста в описании? Этот вопрос бесполезен без него, и если изображение недоступно, это сделало бы вопрос бессмысленным. –

+0

Опубликуйте то, что вы пробовали, и если вы ничего не пробовали, попробуйте сейчас, а затем отправьте сообщение для получения справки. Скорее всего, вы получите помощь, чем ожидаете, что кто-то напишет весь ваш код с нуля. – SJR

+0

@SJR благодарит за предложение. Сделали то же самое –

ответ

0

Попробуйте это. Вам нужно будет изменить путь к файлу и, возможно, ссылки на листы

Sub x() 

Dim rCell As Range, r1 As Range, r2 As Range 
Dim wb As Workbook, ws1 As Worksheet, ws2 As Worksheet 

Application.DisplayAlerts = False 
Application.ScreenUpdating = False 

With ThisWorkbook.Sheets("Sheet1") 
    Set r2 = .Range("A1").CurrentRegion 
    .Cells(1, r2.Columns.Count + 1) = "First" 
    .Cells(2, r2.Columns.Count + 1).Resize(r2.Rows.Count - 1).Formula = "=LEFT(C2,1)" 
    Sheets.Add().Name = "temp" 
    r2.Columns(r2.Columns.Count + 1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("temp").Range("A1"), Unique:=True 
    For Each rCell In Sheets("temp").Range("A2", Sheets("temp").Range("A" & Rows.Count).End(xlUp)) 
     .AutoFilterMode = False 
     .Range("A1").AutoFilter field:=r2.Columns.Count + 1, Criteria1:=rCell 
     Set ws1 = Worksheets.Add(After:=Worksheets(Worksheets.Count)) 
     .AutoFilter.Range.Copy ws1.Range("A1") 
     ws1.Copy 
     Set wb = ActiveWorkbook 
     With wb 
      .Sheets.Add(After:=wb.Sheets(1)).Name = "Temp" 
      .Sheets(1).Range("C1", .Sheets(1).Range("C" & Rows.Count).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Sheets("Temp").Range("A1"), Unique:=True 
      For Each r1 In .Sheets("Temp").Range("A2", .Sheets("Temp").Range("A" & Rows.Count).End(xlUp)) 
       .Sheets(1).Range("A1").AutoFilter field:=3, Criteria1:=r1 
       Set ws2 = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count)) 
       .Sheets(1).AutoFilter.Range.Copy ws2.Range("A1") 
       ws2.Name = r1 
       .Sheets(1).ShowAllData 
      Next r1 
      .Sheets("Temp").Delete 
      .Sheets(1).Delete 
      .Close SaveChanges:=True, Filename:="C:\" & rCell & ".xlsx" 
     End With 
    Next rCell 
    .AutoFilterMode = False 
    Sheets("temp").Delete 
End With 

Application.DisplayAlerts = True 

End Sub 
+0

Это сработало! ... Большое спасибо. –

 Смежные вопросы

  • Нет связанных вопросов^_^