Блог

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

Я пытаюсь разобраться в листе Excel с 411 278 строками, касающимися данных фондового рынка.

Мой код выглядит следующим образом:

     Sub Macro1()
'
' Macro1 Macro
'
        Range("C6:C1577").Select
        Selection.Copy
        Range("D5").Select
        Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
             False, Transpose:=True
        Range("B6:C1577").Select
        Range("C6").Activate
        Application.CutCopyMode = False
        Selection.Delete Shift:=xlUp

End Sub
 

Я пытаюсь вставить приведенный выше код в цикл, который увеличит все числа в цикле на 1.

Например (следующим этапом цикла будет):

     Sub Macro1()
    '
    ' Macro1 Macro
    '
            Range("C7:C1578").Select
            Selection.Copy
            Range("D6").Select
            Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
                 False, Transpose:=True
            Range("B7:C1578").Select
            Range("C7").Activate
            Application.CutCopyMode = False
            Selection.Delete Shift:=xlUp

End Sub
 

Спасибо!

Транспонирование данных

• Ниже будут скопированы только значения (без форматирования или формул).
• Отрегулируйте значения в разделе константы. Обратите внимание, что вы можете выбрать другой рабочий лист для результата, чтобы оставить исходные данные нетронутыми.

Код

 Option Explicit

Sub transposeValues()
    
    ' Define constants.
    Const srcName As String = "Sheet1"
    Const srcColumns As String = "B:D"
    Const srcFirstRow As Long = 5
    Const dstName As String = "Sheet1"
    Const dstFirstCell As String = "B5"
    Const dCount As Long = 1573
    
    ' Define workbook.
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Define Source Range.
    Dim rng As Range
    With wb.Worksheets(srcName).Columns(srcColumns)
        Set rng = .Resize(.Worksheet.Rows.Count - srcFirstRow   1) _
            .Offset(srcFirstRow - 1).Find( _
                What:="*", _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious)
        If rng Is Nothing Then
            Exit Sub
        End If
        Set rng = .Resize(rng.Row - srcFirstRow   1).Offset(srcFirstRow - 1)
    End With
    
    ' Write values from Source Range to Data Array.
    Dim Data As Variant: Data = rng.Value
    
    ' Define Result Array.
    Dim srCount As Long: srCount = UBound(Data)
    Dim Remainder As Long: Remainder = srCount Mod dCount
    Dim drCount As Long
    If Remainder = 0 Then
        drCount = srCount / dCount
    Else
        drCount = Int(srCount / dCount)   1
    End If
    Dim dcCount As Long: dcCount = dCount   1
    Dim Result As Variant: ReDim Result(1 To drCount, 1 To dcCount)
    
    ' Declare counters.
    Dim i As Long, j As Long, k As Long
    
    ' Write values from Data Array to Result Array.
    If drCount = 1 And Remainder > 0 Then
        i = 1
    Else
        For i = 1 To drCount   (Remainder <> 0) * 1 ' In VBA 'True = -1'.
            k = k   1
            For j = 1 To 2
                Result(i, j) = Data(k, j)
            Next j
            For j = 3 To dcCount
                k = k   1
                Result(i, j) = Data(k, 2)
            Next j
        Next i
    End If
    
    ' Write the remainder of values in Data Array to Result Array.
    If Remainder > 0 Then
        k = k   1
        For j = 1 To 2
            Result(i, j) = Data(k, j)
        Next j
        If Remainder > 1 Then
            For j = 3 To 1   Remainder
                k = k   1
                Result(i, j) = Data(k, 2)
            Next j
        End If
    End If
    
    ' Write values from Result Array to Destination Range.
    With wb.Worksheets(dstName).Range(dstFirstCell).Resize(, dcCount)
        .Resize(.Worksheet.Rows.Count - .Row   1).ClearContents
        .Resize(drCount).Value = Result
    End With

End Sub
 

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

 Sub Macro1()

    Dim Rng             As Range
    Dim Rstart          As Long         ' start of range row
    Dim Rend            As Long         ' end of range row
    Dim Target          As Range        ' destination of copy action
    Dim DelRng          As Range        ' range to delete
    
    Rstart = 6
    Rend = 1577
    Application.ScreenUpdating = False
    
    Do
        Set Rng = Range(Cells(Rstart, "C"), Cells(Rend, "C"))
        Set Target = Cells(Rstart - 1, "D")
        Set DelRng = Range(Cells(Rstart, "B"), Cells(Rend, "C"))
        Rng.Copy
        TargetPasteSpecial Paste:=xlPasteAll, _
                           Operation:=xlNone, _
                           SkipBlanks:=False, _
                           Transpose:=True
        DelRng.Delete Shift:=xlUp
        Rstart = Rstart   1
    Loop Until Rstart = Rend
    
    With Application
        .CutCopyMode = False
        .ScreenUpdating = False
    End With
End Sub
 

Основная мера предосторожности — понять код. Начальная и конечная строки указаны вверху. Они используются для установки 3 диапазонов в столбцах C, D и B: C. Изначально это именно ваши 3 диапазона Range («C6: C1577»), Range («D5»), Range («B6: C1577»). Код копирует из первого диапазона во второй, а затем удаляет третий. Это делается без выбора чего-либо, потому что, как только VBA сообщает, где находится диапазон, его не нужно выбирать.

Вы заметите, что нет эквивалента вашему Range("C7").Activate . Это потому, что C7 находится в пределах диапазона Range («B6: C1577»), который предназначен для уничтожения. Не имеет значения, какая ячейка в нем активна. Однако у меня есть некоторые сомнения по поводу удаления и того, действительно ли вы хотели удалить только эту ячейку (чего не делает ваш код). Пожалуйста, проверьте мой код на соответствие вашим намерениям в этом отношении.

Теперь критическая часть. Это цикл. На каждой итерации 3 диапазона перемещаются на одну строку вниз. Строка кода, требующая вашего внимания, — это.

 Loop Until Rng.Row = Rend
 

Цикл будет продолжаться до тех пор, пока первая строка первого диапазона не будет равна Rend . Это означает, что будет 1571 цикл — вероятно, достаточно времени, чтобы выпить кофе и пообщаться, даже если обновление экрана отключено. Но даже это внушающее страх число определенно неверно. Ваш вопрос не дает представления о ваших потребностях, но я думаю, что это должно быть как Loop Until Rng.Row = (411278 - Rend) , плюс-минус 1. Я не хотел вступать в спор об этой последней, последней строке (которая, как правило, опускается в циклах), не веря, что ваше количество строк неизменно. Я думаю, его следует заменить формулой, которая находит последнюю существующую строку в определенном столбце.

Однако ваш вопрос заключался в том, как увеличить диапазоны. Мой код делает это прекрасно. Наслаждайтесь шоу.