Как сделать цикл строки, если еще в Excel VBA Macro и

Question

У меня есть набор данных:

Я хочу перебрать все столбцы и строки, чтобы выбрать ненулевые значения и поместить его вновый лист с месяцем:

Можно ли добиться этого с помощью VBA или Vlookup?

Моя идея такова:

For y in Item No Column
For x in Row
If Qty != 0, append to new sheet
Else go to the next cell

Я не очень уверен, достижимо ли это VBA.

Заранее спасибо!

Answer 1

Это пример того, как циклически проходить через ваши данные с использованием массива.

Option Explicit

Public Sub UnPivotData()
    Dim wsSrc As Worksheet 'define source sheet
    Set wsSrc = ThisWorkbook.Worksheets("Source")

    Dim wsDest As Worksheet 'define output sheet
    Set wsDest = ThisWorkbook.Worksheets("Destination")

    Dim LastRow As Long 'find last used row
    LastRow = wsSrc.Cells(wsSrc.Rows.Count, "A").End(xlUp).Row

    Dim LastCol As Long 'find last used column
    LastCol = wsSrc.Cells(1, wsSrc.Columns.Count).End(xlToLeft).Column

    Dim srcArr As Variant 'read data range into an array (makes it faster)
    srcArr = wsSrc.Range("A1", wsSrc.Cells(LastRow, LastCol)).Value

    Dim OutRow As Long 'find next free output row in destination sheet.
    OutRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row + 1

    Dim iRow As Long, iCol As Long
    For iRow = 2 To UBound(srcArr) 'loop through all rows
        For iCol = 3 To UBound(srcArr, 2) 'loop through month columns
            If srcArr(iRow, iCol) <> 0 Then 'check if quantity is not 0
                With wsDest.Cells(OutRow, 1) 'write everything
                    .Value = srcArr(iRow, 1)
                    .Offset(0, 1).Value = srcArr(iRow, iCol)
                    .Offset(0, 2).Value = srcArr(1, iCol)
                End With
                OutRow = OutRow + 1 'move to the next free row

                'Debug.Print srcArr(iRow, 1), srcArr(iRow, iCol), srcArr(1, iCol)
            End If
        Next iCol
    Next iRow
End Sub

---

Альтернатива, если вы хотите использовать еще более быстрый способ использования массива для вывода тоже

Option Explicit

Public Sub UnPivotDataFastOutput()
    Dim wsSrc As Worksheet 'define source sheet
    Set wsSrc = ThisWorkbook.Worksheets("Source")

    Dim LastRow As Long
    LastRow = wsSrc.Cells(wsSrc.Rows.Count, "A").End(xlUp).Row

    Dim LastCol As Long
    LastCol = wsSrc.Cells(1, wsSrc.Columns.Count).End(xlToLeft).Column

    Dim srcArr As Variant 'read data range into an array
    srcArr = wsSrc.Range("A1", wsSrc.Cells(LastRow, LastCol)).Value

    Dim OutRow As Long
    OutRow = 1

    Dim destRowCount As Long 'calculate array size
    destRowCount = Application.WorksheetFunction.CountIf(wsSrc.Range("C2", wsSrc.Cells(LastRow, LastCol)), "<>0")

    Dim destArr As Variant
    ReDim destArr(1 To destRowCount, 1 To 3)

    Dim iRow As Long, iCol As Long
    For iRow = 2 To UBound(srcArr)
        For iCol = 3 To UBound(srcArr, 2)
            If srcArr(iRow, iCol) <> 0 Then
                'output into array
                destArr(OutRow, 1) = srcArr(iRow, 1)
                destArr(OutRow, 2) = srcArr(iRow, iCol)
                destArr(OutRow, 3) = srcArr(1, iCol)
                OutRow = OutRow + 1

                'Debug.Print srcArr(iRow, 1), srcArr(iRow, iCol), srcArr(1, iCol)
            End If
        Next iCol
    Next iRow

    'write array into sheet
    ThisWorkbook.Worksheets("Destination").Range("A2").Resize(destRowCount, 3).Value = destArr
End Sub

Answer 2

Попробуйте ниже.

Сохранение однозначного значения в ячейке имеет плохие результаты.Я не знаю, когда данные небольшие, но они замедляются при работе с большими объемами данных.Я рекомендую иметь привычку использовать вариантный массив.

Dim rstWs As Worksheet
Dim strSQL As String

Sub test()
    Dim vDB As Variant, vR()
    'vDB is static variant, vR() is Dynamic Variant
    Dim Ws As Worksheet, toWs As Worksheet
    Dim i As Long, j As Integer, n As Long
    Dim r As Long, c As Integer
    Dim wsName As String

    Set Ws = ActiveSheet ' Sheets("Special Name")

    vDB = Ws.Range("a1").CurrentRegion

    r = UBound(vDB, 1)
    c = UBound(vDB, 2)

    For i = 2 To r
        For j = 3 To c
            If vDB(i, j) <> 0 Then
                n = n + 1
                ReDim Preserve vR(1 To 3, 1 To n) 'get data with Tranpose type
                vR(1, n) = vDB(i, 1)
                vR(2, n) = vDB(i, j)
                vR(3, n) = vDB(1, j)
            End If
        Next j
    Next i
    Set toWs = Sheets.Add 'Sheets("Results")
    With toWs
        .UsedRange.Clear
        .Range("a1").Resize(1, 3) = Array("Item No", "Qty", "Month")
        .Range("a2").Resize(n, 3) = WorksheetFunction.Transpose(vR)
    End With
    Set rstWs = Sheets.Add

    wsName = toWs.Name

    strSQL = "Select [Item No], sum(Qty) as Qty "
    strSQL = strSQL & "FROM [" & wsName & "$] "
    strSQL = strSQL & "GROUP BY [Item No] "

    DoSQL
End Sub
Sub DoSQL()

    Dim Rs As Object
    Dim strConn As String
    Dim i As Integer

    strConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=" & ThisWorkbook.FullName & ";" & _
            "Extended Properties=Excel 12.0;"


    Set Rs = CreateObject("ADODB.Recordset")
    Rs.Open strSQL, strConn

    If Not Rs.EOF Then
         With rstWs
            .Range("a1").CurrentRegion.ClearContents
            For i = 0 To Rs.Fields.Count - 1
               .Cells(1, i + 1).Value = Rs.Fields(i).Name
            Next
            .Range("a" & 2).CopyFromRecordset Rs
        End With
    End If
    Rs.Close
    Set Rs = Nothing
End Sub

Предполагается, что данные выглядят следующим образом.

Answer 3

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

dim quantities, months, numbers as Variant

quantities = range("YourQuantityRange")
months = range("YourMonthRange")
numbers = range("YourNumberRange")

Обратите внимание, что вы должны заменить значения диапазона на диапазоны, такие как "A2: A10" или любые другие диапазоны, которые вы используете.Я не знаю, где ваши значения размещены на исходном листе.

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

Dim mySheet As Worksheet
Set mySheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))

Затем вы можете просмотреть свойколичеств. Массив, подобный этому, и выведите правильные значения на второй лист, если число не равно 0

dim i as Long, j as Long, rowCounter as Long
rowCounter = 2 'in which line do you want your first row of data to be written in the second sheet

For i = 1 To UBound(quantities, 1)
    For j = 1 To UBound(quantities, 2)

        if quantities(i, j) <> 0 then
            mySheet.Cells(rowCounter, 1) = numbers(i,1) 'The second parameter of Cells() specifies the column so your item numbers will be pastet in the first column in this example
            mySheet.Cells(rowCounter, 2) = quantities(i,j)
            mySheet.Cells(rowCounter, 3) = months(1,j)
            rowCounter = rowCounter + 1
        end if

    Next
Next

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

Отредактировано на основе комментария Pᴇʜ