chints786 Ответов: 2

Создание макросов в excel с помощью кода VBA

Привет,

Я хочу создать макрос со следующим требованием:-

A	B	C
1234	Color	 Blue
1234	Width	 1.5"
1234	Supplier XYX

output required
A        Colour  Width   Supplier
1234     Blue    1.5"     XYX


Что я уже пробовал:

Я хочу создать макрос с помощью кода VBA.

Mohibur Rashid

И что же? С какой прблемой вы столкнулись?

chints786

Я еще не создал макрос. так что я не знаю, как это делается.

В Интернете я нашел следующий код


Явный Параметр


Суб Атранспрод()
Приложение.ScreenUpdating = False
Дим, как лист С1, С2, как лист
Set s1 = Sheets("вход")
Set s2 = Sheets("OutputX")
С2.Диапазон("А1") = С1.Диапазон("А1")
s2.диапазон("B1") = "Producto"
s2.диапазон("C1") = "Unidad"
s1.диапазон("L1:N1").Копировать s2.Range("D1")
Дим ЛР до тех пор, лр2, как долго, я так долго
lr = s1.Range("A" & Rows.Count).End(xlUp).Row
С s1
Для i = 2 - lr
lr2 = s2.Range("B" & Rows.Count).End(xlUp).Row
Диапазон("A" & i).Копия s2.Range("A" & lr2 + 1)
.Выбор("Б" & я &ампер; ":ж" & я).Копия
s2.Range("B" & lr2 + 1).PasteSpecial xlPasteValues, ,, True
.Диапазон("г" & я &ампер; ":к" & я).Копия
s2.Range("C" & lr2 + 1).PasteSpecial xlPasteValues, ,, True
.Диапазон("л" & я &ампер; ":Н" & я).Копия s2.Range("D" & lr2 + 1)
Затем я
Конец С
Приложение.CutCopyMode = False
lr2 = s2.Range("B" & Rows.Count).End(xlUp).Row
Для i = lr2 - 2 Шаг -1
Если s2.Range("C" & i) = "", то
s2.диапазон("C" & i).Весь день.Удалить
Конец, Если
Затем я
С s2
Для i = 3 - lr2
If .Range("A" & i) = "" тогда
.Range("A" & i) = .Range("A" & i - 1)
.Range("D" & i) = .Range("D" & i - 1)
.Range("E" & i) = .Range("E" & i - 1)
.Range("F" & i) = .Range("F" & i - 1)
Конец, Если
Затем я
Конец С
Приложение.CutCopyMode = False
Приложение.ScreenUpdating = True
MsgBox "завершено"
Конец Подводной Лодки

2 Ответов

Рейтинг:
16

Maciej Los

Предположим, что рабочий лист № 1 содержит перечисленные ниже данные, начиная с ячейки A1:

ID	Property	Value
1234	Color	Blue
1234	Width	1.5"
1234	Supplier	XYX
1235	Color	Orange
1235	Width	3.5"
1235	Supplier	ZZA


и вы хотите достичь чего-то подобного (в рабочем листе № 2):
ID	Color	Width	Supplier
1234	Blue	1.5"	XYX
1235	Orange	3.5"	ZZA


ниже макрос должен выполнить эту работу:

Option Explicit

Sub RowsToColumns()
    Dim i As Integer, j As Integer, k As Integer
    Dim srcWsh As Worksheet, dstWsh As Worksheet
    
    On Error GoTo Err_RowsToColumns

    'you need to change a code-context!
    'read below comments
    Set srcWsh = ThisWorkbook.Worksheets(1) 'refers to first worksheet in a workbook - source worksheet
    Set dstWsh = ThisWorkbook.Worksheets(2) 'refers to second worksheet in a workbook - destination worksheet
    dstWsh.Cells.Delete xlShiftUp 'clean up first!
    With dstWsh.Range("A1")
        .Value = "ID"
        .Font.Bold = True
        .Interior.Color = vbGreen
    End With
    
    i = 2
    j = 2
    Do While srcWsh.Range("A" & i) <> ""
        'ID
        dstWsh.Range("A" & j) = srcWsh.Range("A" & i)
        'other properties
        k = 0
        Do While srcWsh.Range("A" & i + k) = srcWsh.Range("A" & i)
            With dstWsh.Range("B1").Offset(ColumnOffset:=k)
                .Value = srcWsh.Range("B" & i + k)
                .Font.Bold = True
                .Interior.Color = vbGreen
            End With
            dstWsh.Range("B" & j).Offset(ColumnOffset:=k) = srcWsh.Range("C" & i + k)
            k = GetColumnNo(srcWsh.Range("B" & i + k), dstWsh)
        Loop
        i = i + k
        j = j + 1
    Loop
    
Exit_RowsToColumns:
    On Error Resume Next
    Set srcWsh = Nothing
    Set dstWsh = Nothing
    Exit Sub

Err_RowsToColumns:
    MsgBox Err.Description, vbExclamation, Err.Number
    Resume Exit_RowsToColumns


End Sub

Function GetColumnNo(sHeader As String, wsh As Worksheet) As Integer
    Dim c As Integer
    
    c = 0
    Do While wsh.Range("A1").Offset(ColumnOffset:=c) <> ""
        If wsh.Range("A1").Offset(ColumnOffset:=c) = sHeader Then Exit Do
        c = c + 1
    Loop
    
    GetColumnNo = c

End Function


Примечание: данные и приведенный выше макрос должны находиться в одной рабочей книге.

chints786

Привет Мацей,

Я получаю ошибку "индекс вне диапазона"

Maciej Los

Потому что ты не читал мои комментарии...

chints786

Возможно, я пытался изменить какой-то код, основываясь на ваших комментариях, но я могу ошибаться.

- вам нужно изменить код-контекст!
"читайте ниже комментарии
Набор srcWsh = "Лист1" 'ссылается на первый лист книги - Источник листе
Set dstWsh = sheet2 'относится ко второму листу в рабочей книге - целевому листу
дствш.Ячейки.Сначала удалите xlShiftUp 'clean up!
С dstWsh.Диапазон("A1")
.Значение = "код"
.Шрифт.Жирный = Истина
.Интерьер.Цвет = vbGreen
Конец С

было ли это то, что требовалось?

Maciej Los

Заменять:

Set srcWsh = Sheet1

с:
Set srcWsh = ThisWorkbook.Worksheets("Sheet1") 'where Sheet1 is the name of sheet

chints786

Огромное спасибо Мацей. Я смог сделать необходимые изменения. Еще раз спасибо за вашу помощь!!!

Maciej Los

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

chints786

Сделано.

Еще раз спасибо!!

Maciej Los

Спасибо!

Рейтинг:
0

Richard MacCutchan

Используйте функцию записи макросов.
- Начать запись
- Выполняйте действия, которые вы хотите
- Прекратите запись.
Теперь вы можете редактировать и изменять макрос по мере необходимости.

chints786

Ричард, я хочу создать макрос, но никогда его не создавал
поэтому, пожалуйста, помогите мне создать его.

Richard MacCutchan

Следуйте приведенным выше инструкциям. Альтернативно читайте Быстрый старт: создание макроса - офисная поддержка[^].