Скопировать диапазон данных на основе значения ячейки

Question

У меня есть список с колонками от A до C. Столбец B содержит либо "A", "B" или "C". Мне нужно скопировать все данные из столбцов от A до C на новый лист в зависимости от значения в столбце B.

Я хочу скопировать на лист 1, когда столбец B - "A", на лист 2, если столбец B - "B", и на лист 3, если столбец B - "C".

Я пробовал VBA, используя For i = 1 to .End(xlUp).Offset(0) , но что мне делать? То, что я попробовал, совсем не работало на меня.

Answer 1

Извините, но у меня только есть время проверить это и не работает. Это зависало во время "Dim copySheet As Excel.Рабочий лист: установите copySheet = ThisWorkbook.Worksheets(copySheetName)»

мои исходные данные в листе "data", я уже обновил имя до Const copySheetName As String = "data"

Есть ли у вас какие-либо идеи, почему это не работает. Спасибо.

Answer 2

В приведенном ниже коде предполагается, что лист с копируемыми данными называется "Главный". Он также предполагает, что ваши "вставленные" листы содержат заголовки столбцов, поэтому он начнет вставку со строки 2. Если это не то, что вы хотите, удалите .Offset(1, 0) вызов с линии, выполняющей вставку.

Возможно, вам понадобится лучшая обработка ошибок, чем Debug.Print строку, но я оставлю это на ваше усмотрение.

Протестировано в Excel 2007 и работает как положено.

Sub DoCopy()

  Const copySheetName As String = "Main"
  Dim rw As Integer
  Dim lngRowStart As Long
  Dim lngRowEnd As Long

  Dim copySheet As Excel.Worksheet: Set copySheet = ThisWorkbook.Worksheets(copySheetName)
  Dim pasteSheet As Excel.Worksheet

  lngRowStart = 1 'number of first row containing data to copy
  lngRowEnd = 17  'number of last row containing data to copy

  'the "Copy" sheet be the active sheet in order to copy/paste (avoid run-time error 1004)
  ThisWorkbook.Worksheets(copySheetName).Activate

  For rw = lngRowStart To lngRowEnd

    copySheet.Range(Cells(rw, 1), Cells(rw, 3)).Copy

    Select Case Cells(rw, 2)
      Case "a"
        Set pasteSheet = ThisWorkbook.Worksheets("Sheet1")
      Case "b"
        Set pasteSheet = ThisWorkbook.Worksheets("Sheet2")
      Case "c"
        Set pasteSheet = ThisWorkbook.Worksheets("Sheet3")
      Case Else
        Debug.Print "Invalid Value: " & Cells(rw, 2) & " (row " & rw & ")"
        GoTo SkipRow
    End Select

    pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

SkipRow:
  Next rw

  Application.CutCopyMode = False
  Set copySheet = Nothing
  Set pasteSheet = Nothing
End Sub