Страницы: 1
RSS
Вставить нужный текст в ячейки через определенное количество строк.
 
Добрый день , помогите пожалуйста  со скриптом , у меня есть плейлист музыки и мне нужно через каждых пять треков вставлять разных  5 рекламных аудио ролика.
во вложении пример на первом листе оригинал а на втором нужный результат.

Получается начиная со второй строки через 14 строк создать 2 пустые строки и вставить в строку 1 текст "#EXTINF:0,audio-1.mp3" в строку 2 текст "audio-1.mp3" потом опять через 14 строк создать 2 пустые строки и вставить в строку 1 "#EXTINF:0,audio-2.mp3" в строку 2 "audio-2.mp3"
Изменено: Алексей Коваленко - 17.06.2021 15:14:13
 
Код
Sub КислотныйДиджей()
    Dim sh1 As Worksheet
    Set sh1 = ActiveSheet
    
    Dim sh2 As Worksheet
    Set sh2 = ActiveSheet
    
    Dim y As LongPtr
    Dim arr As Variant
    
    With sh1
        y = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        arr = .Range(.Cells(1, 1), .Cells(y, 1))
    End With
    
    y = (UBound(arr, 1) - 1) * 1.3 + 1
    Dim brr As Variant
    Dim u As Long
    Dim j As Long
    Dim i As Byte
    
    ReDim brr(1 To y, 1 To 1)
    brr(1, 1) = arr(1, 1)
    u = 1
    j = 1
    For y = 2 To UBound(arr, 1)
        u = u + 1
        If u > UBound(brr, 1) Then Exit For
        brr(u, 1) = arr(y, 1)
        i = i + 1
        If i = 15 Then
            u = u + 1
            If u > UBound(brr, 1) Then Exit For
            brr(u, 1) = "#EXTINF:0,audio-" & j & ".mp3"
            u = u + 1
            If u > UBound(brr, 1) Then Exit For
            brr(u, 1) = "audio-" & j & ".mp3"
            u = u + 1
            j = j + 1
            i = 0
        End If
    Next
    
    sh2.Cells(1, 10).Resize(UBound(brr, 1), 1) = brr
End Sub
Изменено: МатросНаЗебре - 17.06.2021 15:16:53
 
МатросНаЗебре,  не сработал скрипт :( , при выполнении скрипта ошибка Compile error: Type mismatch , ругнулось на 22 строчку скрипта
Изменено: Алексей Коваленко - 17.06.2021 15:33:39
 
Код
Option Explicit
Sub AddAdvertising()
    Const MAX_ADV As Integer = 3
    Dim i As Long, rnd As Integer
    With ActiveWorkbook.Sheets("Лист1")
        rnd = MAX_ADV
        For i = .Cells(Rows.Count, 1).End(xlUp).Row + 2 To 10 Step -1
            If i Mod 15 = 2 Then
                .Rows(i).Insert Shift:=xlDown
                .Rows(i).Insert Shift:=xlDown
                .Rows(i).Insert Shift:=xlDown
                .Range("A" & i) = "#EXTINF:0,audio-" & rnd & ".mp3"
                .Range("A" & i + 1) = "audio-" & rnd & ".mp3"
                If rnd = 1 Then
                    rnd = MAX_ADV
                Else
                    rnd = rnd - 1
                End If
            End If
        Next i
        
    End With
End Sub
 
Цитата
Алексей Коваленко написал:
ругнулось на 22 строчку скрипта
На эту?
Код
ReDim brr(1 To y, 1 To 1)
 
МатросНаЗебре,  Да
 
На примере из #1 работает. Приложите пример, на котором возникает ошибка, в формате xlsx.
 
Цитата
МатросНаЗебре написал:
На примере из #1 работает. Приложите пример, на котором возникает ошибка, в формате xlsx.
 
Этот пример обработал без ошибок.
 
vokilook,

Опробовал ваш скрипт, вроде работает но немного некорректно

заменил значение  
Код
Const MAX_ADV As Integer = 5 


и у меня первый вставленный трек получился

#EXTINF:0,audio-3.mp3
audio-3.mp3

а не

#EXTINF:0,audio-1.mp3
audio-1.mp3
 
Цитата
МатросНаЗебре написал:
Этот пример обработал без ошибок.
Изменено: Алексей Коваленко - 17.06.2021 16:27:05
 
У меня опечатка. Должно быть
Код
Dim y As Long
 
МатросНаЗебре, Да теперь заработал , но немного не так как я ожидал , мне нужно чтобы создавался текст в таком порядке
Скрытый текст


и было бы неплохо устанавливать количество с 3 до 5 к примеру
Изменено: Алексей Коваленко - 17.06.2021 16:44:58
 
МатросНаЗебре, , Да теперь заработал , но немного не так как я ожидал , мне нужно чтобы создавался текст в таком порядке
Скрытый текст
Изменено: Алексей Коваленко - 17.06.2021 16:56:06
 
Код
Sub КислотныйДиджей()
    
    Const Nmax = 4
    
    Dim sh1 As Worksheet
    Set sh1 = ActiveSheet
    
    Dim sh2 As Worksheet
    Set sh2 = ActiveSheet
    
    Dim y As Long
    Dim arr As Variant
    
    With sh1
        y = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        arr = .Range(.Cells(1, 1), .Cells(y, 1))
    End With
    
    y = (UBound(arr, 1) - 1) * 1.3 + 1
    Dim brr As Variant
    Dim u As Long
    Dim j As Byte
    Dim i As Byte
    
    ReDim brr(1 To y, 1 To 1)
    brr(1, 1) = arr(1, 1)
    u = 1
    j = 1
    For y = 2 To UBound(arr, 1)
        u = u + 1
        If u > UBound(brr, 1) Then Exit For
        brr(u, 1) = arr(y, 1)
        i = i + 1
        If i = 15 Then
            u = u + 1
            If u > UBound(brr, 1) Then Exit For
            brr(u, 1) = "#EXTINF:0,audio-" & j & ".mp3"
            u = u + 1
            If u > UBound(brr, 1) Then Exit For
            brr(u, 1) = "audio-" & j & ".mp3"
            u = u + 1
            j = j + 1
            If j > Nmax Then j = 1
            i = 0
        End If
    Next
    
    sh2.Cells(1, 10).Resize(UBound(brr, 1), 1) = brr
End Sub

 
В этом варианте количество указывать не нужно. Можно использовать не только числа в именах audio-?.mp3.
Код
Sub КислотныйДиджей()
    
    Dim arrAudio As Variant
    arrAudio = Array("audio-1.mp3", "audio-2.mp3", "audio-AAA.mp3")
    
    Dim sh1 As Worksheet
    Set sh1 = ActiveSheet
    
    Dim sh2 As Worksheet
    Set sh2 = ActiveSheet
    
    Dim y As Long
    Dim arr As Variant
    
    With sh1
        y = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        arr = .Range(.Cells(1, 1), .Cells(y, 1))
    End With
    
    y = (UBound(arr, 1) - 1) * 1.3 + 1
    Dim brr As Variant
    Dim u As Long
    Dim j As Byte
    Dim i As Byte
    
    ReDim brr(1 To y, 1 To 1)
    brr(1, 1) = arr(1, 1)
    u = 1
    j = LBound(arrAudio)
    For y = 2 To UBound(arr, 1)
        u = u + 1
        If u > UBound(brr, 1) Then Exit For
        brr(u, 1) = arr(y, 1)
        i = i + 1
        If i = 15 Then
            u = u + 1
            If u > UBound(brr, 1) Then Exit For
            brr(u, 1) = "#EXTINF:0," & arrAudio(j)
            u = u + 1
            If u > UBound(brr, 1) Then Exit For
            brr(u, 1) = arrAudio(j)
            u = u + 1
            j = j + 1
            If j > UBound(arrAudio) Then j = LBound(arrAudio)
            i = 0
        End If
    Next
    
    sh2.Cells(1, 10).Resize(UBound(brr, 1), 1) = brr
End Sub

Изменено: МатросНаЗебре - 17.06.2021 16:59:07
 
МатросНаЗебре, Супер , Спасибо Вам большое !!!!
 
Код
Sub m3()
    Dim ash As Worksheet, m3u As Worksheet
    Dim audio, i&, j&, lr&
    audio = Array("audio-1", "audio-2", "audio-3", "audio-4", "audio-5")
    Set ash = ActiveSheet
    Set m3u = Worksheets.Add(after:=Sheets(Sheets.Count))
    Application.ScreenUpdating = False
    ash.Cells(1, 1).Copy m3u.Cells(1, 1)
    For i = 2 To ash.Cells(Rows.Count, 1).End(xlUp).Row Step 15
        lr = m3u.Cells(Rows.Count, 1).End(xlUp).Row + 1
        lr = lr - (lr > 2)
        ash.Cells(i, 1).Resize(15).Copy m3u.Cells(lr, 1)
        lr = m3u.Cells(Rows.Count, 1).End(xlUp).Row + 2
        m3u.Cells(lr, 1) = "#EXTINF:0," & audio(j) & ".mp3"
        m3u.Cells(lr + 1, 1) = audio(j) & ".mp3"
        j = -(j + 1) * (j < UBound(audio))
    Next
    Application.ScreenUpdating = True
End Sub
 
RAN, Большое спасибо и за Ваш скрипт !!!
Страницы: 1
Наверх