Как создать макрос, который будет копировать данные из строки в столбец, используя условия?

Question

В настоящее время я использую v lookup, чтобы найти и разместить значения для определенного элемента. Тем не менее, я ищу помощь для макроса VB, который будет выводить данные с определенным результатом.

см. Первый снимок экрана с необработанными данными

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

Обратите внимание, что «сайт» не является константой, это может быть любое значение, поэтому я поместил весь сайт в столбец А.

В настоящее время V look делает свою работу хорошо. но иногда вызывает сбой файла.

Answer 1

Вы можете решить эту проблему с помощью сводной таблицы, используя исходный источник данных, без изменений в макете таблицы.

Перетащите столбцы, как показано ниже (вам нужно переименовать их по умолчаниюимена) : для Columns сначала перетащите туда поле Date.Поле Σ Values появится после перетаскивания двух полей в область значений и должно быть ниже Date.

И снекоторые изменения форматирования по умолчанию, результат может выглядеть следующим образом:

Answer 2

Там вопрос легко решается с помощью сводной таблицы. Для практики я создаю ниже.

Предположим, что:

1. Данные отображаются в листе «Данные»

2. Результаты будут заполнены в листе «Результаты»

   Option Explicit
   
   Sub Allocation()
   
   Dim LastRow As Long, Row As Long, Column As Long, Invetory As Long, Sold As Long, Remaining As Long, LastRowRes As Long, LastColRes As Long, CurrentCol As Long, CurrentRow As Long, i As Long, y As Long
   Dim iDate As Date
   Dim Site As String
   Dim wsData As Worksheet, wsResults As Worksheet
   Dim ExcistSite As Boolean, ExcistDate As Boolean
   
   Set wsData = ThisWorkbook.Worksheets("Data")
   Set wsResults = ThisWorkbook.Worksheets("Results")
   
   LastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row
   
   wsResults.UsedRange.Clear
   
   For Row = 2 To LastRow
   
       iDate = wsData.Cells(Row, 1).Value
       Site = wsData.Cells(Row, 2).Value
       Invetory = wsData.Cells(Row, 3).Value
       Sold = wsData.Cells(Row, 4).Value
       Remaining = wsData.Cells(Row, 5).Value
   
       If Row = 2 Then
   
           With wsResults.Range("B1:D1")
               .Merge
               .Value = iDate
           End With
   
           wsResults.Range("A2").Value = "Site"
           wsResults.Range("A2").Offset(1, 0).Value = Site
           wsResults.Range("B2").Value = "Invetory"
           wsResults.Range("B2").Offset(1, 0).Value = Invetory
           wsResults.Range("C2").Value = "Sold"
           wsResults.Range("C2").Offset(1, 0).Value = Sold
           wsResults.Range("D2").Value = "Remaining"
           wsResults.Range("D2").Offset(1, 0).Value = Remaining
   
       Else
           'Check if Site appears
           LastRowRes = wsResults.Cells(wsResults.Rows.Count, "A").End(xlUp).Row
   
           For i = 3 To LastRowRes
               ExcistSite = False
               If wsResults.Cells(i, 1).Value = Site Then
                   CurrentRow = i
                   ExcistSite = True
                   Exit For
               Else
                   CurrentRow = i + 1
               End If
           Next i
   
           If ExcistSite = False Then
               wsResults.Cells(CurrentRow, 1).Value = Site
           End If
   
           'Check if date appears
           LastColRes = wsResults.Cells(1, wsResults.Columns.Count).End(xlToLeft).Column
   
           For y = 2 To LastColRes
               ExcistDate = False
               If wsResults.Cells(1, y).Value = iDate Then
                   CurrentCol = y
                   ExcistDate = True
                   Exit For
               Else
                   CurrentCol = y + 1
               End If
           Next y
   
           If ExcistDate = False Then
   
               wsResults.Cells(2, CurrentCol + 2).Value = "Invetory"
               wsResults.Cells(i, CurrentCol + 2).Value = Invetory
               wsResults.Cells(2, CurrentCol + 3).Value = "Sold"
               wsResults.Cells(i, CurrentCol + 3).Value = Sold
               wsResults.Cells(2, CurrentCol + 4).Value = "Remaining"
               wsResults.Cells(i, CurrentCol + 4).Value = Remaining
   
               With wsResults.Range(Cells(1, LastColRes + 3), Cells(1, LastColRes + 5))
                   .Merge
                   .Value = iDate
               End With
   
           Else
               wsResults.Cells(CurrentRow, CurrentCol).Value = Invetory
               wsResults.Cells(CurrentRow, CurrentCol + 1).Value = Sold
               wsResults.Cells(CurrentRow, CurrentCol + 2).Value = Remaining
           End If
   
       End If
   
   Next Row
   
   LastColRes = wsResults.Cells(1, wsResults.Columns.Count).End(xlToLeft).Column
   LastRowRes = wsResults.Cells(wsResults.Rows.Count, "A").End(xlUp).Row
   
   With wsResults.Range(Cells(1, 2), Cells(1, LastColRes))
       With .Font
           .Bold = True
           .ThemeColor = xlThemeColorDark1
       End With
       With .Interior
           .ThemeColor = xlThemeColorAccent1
       End With
   End With
   
   With wsResults.Cells(2, 1)
       With .Font
           .Bold = True
           .ThemeColor = xlThemeColorDark1
       End With
       With .Interior
           .ThemeColor = xlThemeColorLight1
       End With
   End With
   
   For i = 2 To LastColRes Step 3
   
       With wsResults.Range(Cells(2, i), Cells(LastRowRes, i))
   
           With .Interior
               .ThemeColor = xlThemeColorAccent1
               .TintAndShade = 0.399975585192419
           End With
   
       End With
   
   Next i
   
   For i = 3 To LastColRes + 3 Step 3
   
       With wsResults.Range(Cells(2, i), Cells(LastRowRes, i + 1))
   
           With .Font
               .ThemeColor = xlThemeColorDark2
               .TintAndShade = -0.249977111117893
           End With
   
       End With
   
   Next i
   
   With wsResults.UsedRange
       .Borders.LineStyle = xlContinuous
       .HorizontalAlignment = xlCenter
       .VerticalAlignment = xlCenter
       .EntireColumn.AutoFit
   End With
   
   End Sub
   

Answer 3

Можете ли вы изменить исходные данные?
Если вы измените свои данные так, чтобы они выглядели как таблица «Измененные исходные данные» ниже, вы можете решить эту проблему с помощью сводной таблицы.

Решение с помощью сводной таблицы

Измененные исходные данные