Код VBA для копирования из нескольких строк и столбцов для непустого значения

Question

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

Во время процесса я хочу отфильтровать все пустые значения и скопировать только строки со значениями. Начиная со столбца D из файла, над которым я работаю (см. Приложение), я хочу отфильтровать непустые значения и скопировать их в столбцы B, C, D, CellD2, CellD3 в 5 столбцах нового листа. Затем повторите то же самое для всех столбцов, которые имеют значение после столбца D. В наборе данных, над которым я работаю, может быть несколько столбцов (без фиксированного предела) и несколько строк (без фиксированного предела)

Заранее спасибо. Это данные, над которыми я работаю (имя листа "LJM Fert")

Это конечный результат, которого я пытаюсь достичь (имя листа "Экспорт")

Ниже приведен код, который я написал до сих пор, но не работает Sub CopyPaste ( )

Dim Totalrows As Long
Dim Totalcolumns As Long
Dim rowloop As Long
Dim columnloop As Long
Dim rowcount As Long
Dim columncount As Long
Dim pastestart As Long





   Sheets("LJM Fert").Activate

   Totalrows = ActiveSheet.UsedRange.Rows.Count
   Totalcolumns = ActiveSheet.UsedRange.Columns.Count
   rowcount = 4
   columncount = 4
   pastestart = 2


    For rowloop = rowcount To Totalrows


        For columnloop = columncount To Totalcolumns


        If ActiveSheet.Cells(rowcount, columncount).Value <> "" Then
        ActiveSheet.Cells(rowcount, 2).Copy
        Sheets("Export").Activate
        ActiveSheet.Cells(pastestart, 1).Paste
        Sheets("LJM Fert").Activate


        ActiveSheet.Cells(rowcount, 3).Copy
        Sheets("Export").Activate
        ActiveSheet.Cells(pastestart, 2).Paste
        Sheets("LJM Fert").Activate


        ActiveSheet.Cells(rowcount, columncount).Copy
        Sheets("Export").Activate
        ActiveSheet.Cells(pastestart, 3).Paste
        Sheets("LJM Fert").Activate


        ActiveSheet.Cells(2, columncount).Copy
        Sheets("Export").Activate
        ActiveSheet.Cells(pastestart, 4).Paste
        Sheets("LJM Fert").Activate


        ActiveSheet.Cells(3, columncount).Copy
        Sheets("Export").Activate
        ActiveSheet.Cells(pastestart, 5).Paste
        Sheets("LJM Fert").Activate

        End If

    columncount = columncount + 1
    pastestart = pastestart + 1

    Next
    Next




Application.CutCopyMode = False
'ThisWorkbook.Worksheets("Export").Cells(1, 1).Select

End Sub

Answer 1

Вы можете сделать что-то вроде этого:

'Define Variables
Dim shtExport As Worksheet, shtFert As Worksheet
Dim i As Integer
Dim cell as Range

'Assign Variables
Set shtExport = Sheets("Export")
Set shtFert = Sheets("LJM Fert")

i = 1 'first line where to copy data in Sheet "Export"

For Each cell In shtFert.Range("D4:G20") 'Go through each cell in table

    If cell.Value <> 0 Then

        shtExport.Cells(i, 1) = shtFert.Cells(cell.Row, 2) 'Column A
        shtExport.Cells(i, 2) = shtFert.Cells(cell.Row, 3) 'Column B
        shtExport.Cells(i, 3) = shtFert.Cells(cell.Row, cell.Column) 'Column C
        shtExport.Cells(i, 4) = shtFert.Cells(2, cell.Column) 'Column D
        shtExport.Cells(i, 5) = shtFert.Cells(3, cell.Column) 'Column E

    i = i + 1 'use next row in sheet Export

    End If

Next

То, что это в основном делает, это go через каждую ячейку в диапазоне D4: G20 вашего листа "LJM Fert", проверяет, отличается ли эта ячейка чем 0, если это так: он будет «копировать» эту ячейку на листе экспорта. И так для каждой ячейки, отличной от 0.

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