How to generate a spreadsheet from another using VBA

Asked

Viewed 7,295 times

6

I have the worksheet below with the following columns:

inserir a descrição da imagem aqui

I would like to generate a second spreadsheet based on the above information, following the following conditions:

a) If categoria == 'Multimídia > Multilaser', categoria = '1'

b) If categoria == 'Sestini > Meninos', categoria = '2'

c) The new generated columns will be:

  1. Title name(en);
  2. Category Categories;
  3. Units D. Quantity;
  4. Price price;
  5. Date of creation date_added.

d) The columns Questions and State shall not compose the new spreadsheet

e) The new spreadsheet should contain some fields (Shipping, sku and model) that will already come with a value default

  1. model shall have the same value as Title

Desired result (new spreadsheet):

inserir a descrição da imagem aqui

My intention is to automate this process, given that the original spreadsheet is exported from another site in the format . CSV, where I used the Convert to generate the . XLS.

excel vba

  • @Cantoni, I’ve been searching and found your answer in this topic. Could help me here too?

  • You want to generate a new worksheet in the same document or generate a new workbook (new file)?

  • @Pedromvm independent, the two will meet me.

  • "model will have the same Title value", but at line 3 of its expected result is the category name. I am taking the statement, even seeing that columns A and E will contain the same value.

4 answers

2

I did the code below following the good programming practices, using more appropriate variable names with their use, and not using ActiveCell, Offset and other things like that. I hope you prefer it this way.

Option Explicit
Option Private Module
Sub Principal()

    Dim PlanilhaAtual As Worksheet
    Dim PlanilhaNova As Worksheet

    Set PlanilhaAtual = Worksheets(1)

    GerarPlanilha ("Nova")
    Set PlanilhaNova = Worksheets("Nova")

    Dim UltimaLinha As Long
    UltimaLinha = PlanilhaAtual.Cells.Find("*", LookIn:=xlFormulas, _
        SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

' Copiando os valores para a planilha nova
    Dim Linha As Long
    For Linha = 2 To UltimaLinha
        PlanilhaNova.Cells(Linha, 1).Value = PlanilhaAtual.Cells(Linha, 2).Value
        PlanilhaNova.Cells(Linha, 2).Value = _
            ConverterCategoria(CStr(PlanilhaAtual.Cells(Linha, 1).Value))
        PlanilhaNova.Cells(Linha, 3).Value = "yes"
        PlanilhaNova.Cells(Linha, 4).Value = PlanilhaAtual.Cells(Linha, 4).Value
        PlanilhaNova.Cells(Linha, 5).Value = PlanilhaAtual.Cells(Linha, 2).Value
        PlanilhaNova.Cells(Linha, 6).Value = ""
        PlanilhaNova.Cells(Linha, 7).Value = PlanilhaAtual.Cells(Linha, 6).Value
        PlanilhaNova.Cells(Linha, 8).Value = PlanilhaAtual.Cells(Linha, 7).Value
    Next

End Sub
Sub GerarPlanilha(Nome As String)

    Dim Planilha As Worksheet

' Excluindo planilha existente se houver
    For Each Planilha In Worksheets
        If Planilha.Name = Nome Then
            Application.DisplayAlerts = False
            Planilha.Delete
            Application.DisplayAlerts = True
        End If
    Next

' Criando a planilha nova
    Set Planilha = Worksheets.Add(After:=Sheets(Sheets.Count))
    Planilha.Name = Nome

' Gerando cabeçalho na planilha nova
    Range("A1").Value = "name(pt-br)"
    Range("B1").Value = "categories"
    Range("C1").Value = "shipping"
    Range("D1").Value = "quantity"
    Range("E1").Value = "model"
    Range("F1").Value = "sku"
    Range("G1").Value = "price"
    Range("H1").Value = "date_added"

End Sub
Function ConverterCategoria(Texto As String) As Long

'  O valor 0 é retornado caso o texto não tenha um valor correspondente
    Select Case Texto
        Case "Multimídia > Multilaser"
            ConverterCategoria = 1
        Case "Sestini > Meninos"
            ConverterCategoria = 2
        Case Else
            ConverterCategoria = 0
    End Select

End Function

The code contains a main routine (the one you should run), a subroutine to create the new worksheet (and delete, if any) and a function to generate the category value.

The use of the function is better in this case, since new values can be added, so I kept to the part, without mixing with the rest of the code. I also put the 0 return in case the text is not found. If you find any category with value 0, you need to see which (or which) were the categories that are not foreseen(s) and add in the code.

If there are any questions about the code or some excerpt that needs to be better explained, just ask that I answer.

  • Hello @Pedromvm, well structured and succinct code. However, two caveats: a) The use of Private Module generated the following error: Option Private Module not permitted in an object module, what would it be? b) No addition of the header to the new Spreadsheet, that is to say Planilha.Range("A1").Value = "name(pt-br)", and so on.

  • Hello. The option Option Private Module serves so that the existing function in the module is not available as a worksheet function. You can comment or take out this line, the only difference is that you can use the function ConverterCategoria in your spreadsheet. But this should not disturb anything. With respect to the header in the new worksheet, it is created in the subroutine GerarPlanilha, that checks if there is a spreadsheet with that name (deleting in this case without the Excel alert) and then generates a new spreadsheet at the end of the list of spreadsheets. If you need to, add Planilha. before the Range.

1

tested here and it worked, insert a button in the spreadsheet with the macro below. It will generate another spreadsheet in the same file.

Sub geraPlanilha()
    Dim contador As Integer
    Dim planilhaOriginal As Worksheet
    Dim novaPlanilha As Worksheet
    Set planilhaOriginal = Workbooks("teste.xlsm").Worksheets(1)
    Set novaPlanilha = Workbooks("teste.xlsm").Worksheets.Add()

    'adicionar cabeçalho
    novaPlanilha.Cells(1, 1) = "name(pt-br)"
    novaPlanilha.Cells(1, 2) = "categories"
    novaPlanilha.Cells(1, 3) = "shipping"
    novaPlanilha.Cells(1, 4) = "quantity"
    novaPlanilha.Cells(1, 5) = "model"
    novaPlanilha.Cells(1, 6) = "sku"
    novaPlanilha.Cells(1, 7) = "price"
    novaPlanilha.Cells(1, 8) = "date_added"

    contador = 2
    'Faz um loop em todas as linhas em que a primeira coluna estiver preenchida
    Do While planilhaOriginal.Cells(contador, 1) <> ""
        'name(pt-br)
        novaPlanilha.Cells(contador, 1) = planilhaOriginal.Cells(contador, 2)
        'categories
        If planilhaOriginal.Cells(contador, 1) = "Multimídia > Multilaser" Then
             novaPlanilha.Cells(contador, 2) = 1
        Else
            novaPlanilha.Cells(contador, 2) = 2
        End If
        'shipping
        novaPlanilha.Cells(contador, 3) = "yes"
        'quantity
        novaPlanilha.Cells(contador, 4) = planilhaOriginal.Cells(contador, 4)
        'model
        novaPlanilha.Cells(contador, 5) = planilhaOriginal.Cells(contador, 2)
        'sku
        novaPlanilha.Cells(contador, 6) = ""
        'price
        novaPlanilha.Cells(contador, 7) = planilhaOriginal.Cells(contador, 6)
        'date_added
        novaPlanilha.Cells(contador, 8) = planilhaOriginal.Cells(contador, 7)

        contador = contador + 1
    Loop
End Sub

You can improve, making these categories be searched in another spreadsheet instead of being fixed in the code, but there is at your discretion.

1

Luccas,

I don’t know how many lines will be executed. But I would do so.

A new CSV query to export CSV data, already breaking into columns by delimiter. With this, whenever you run, it just needs to update this query and you will have all the lines of CSV, which updates so:

Sheets("Planilha1").Select
Range("A1").Select
Selection.ListObject.QueryTable.Refresh BackgroundQuery:=False

After that, with a code similar to this, you can bring the data from one to the other already in the desired format.

Range("A2").Select
NumeroLinhas = Range("A2", Range("A2").End(xlDown)).Rows.Count

Range("A2").Select
For x = 1 To NumeroLinhas
    Range("Planilha3!" + ActiveCell.Address) = ActiveCell.Value
    Range("Planilha3!" + ActiveCell.Offset(0, 1).Address) = ActiveCell.Offset(0, 1).Value
    Range("Planilha3!" + ActiveCell.Offset(0, 2).Address) = ActiveCell.Offset(0, 2).Value
    Range("Planilha3!" + ActiveCell.Offset(0, 3).Address) = ActiveCell.Offset(0, 3).Value

    ActiveCell.Offset(1, 0).Select
Next

Note that you will paste the direct value into the column you need just by scrolling with the offset.

1

Check the following code... Missing implement the attribution logic of the respective column values

Sub copyTemplate()

Dim wk As Workbook
Dim fileOriginal As Worksheet
Dim lastRow, i As Integer
Set wk = Workbooks.Add

'adicionar cabeçalho
wk.Worksheets("Sheet1").Cells(1, 1) = " name(pt-br)"
wk.Worksheets("Sheet1").Cells(1, 2) = "categories"
wk.Worksheets("Sheet1").Cells(1, 3) = "quantity"
wk.Worksheets("Sheet1").Cells(1, 4) = "price"
wk.Worksheets("Sheet1").Cells(1, 5) = "date_added"
wk.Worksheets("Sheet1").Cells(1, 6) = "shipping"
wk.Worksheets("Sheet1").Cells(1, 7) = "sku"
wk.Worksheets("Sheet1").Cells(1, 8) = "model"

'file original onde estão os dados para ser copiados
'nome do ficheiro original...
'quando executares a macro o ficheiro deve estar a aberto
Set fileOriginal = Workbooks("StackOverflowCopyTest.xlsm").Worksheets("Folha1")
'busca a ultima linha do ficheiro original
lastRow = fileOriginal.Cells(fileOriginal.Rows.Count, 1).End(xlUp).Row
'percorre o ficheiro original e copia para o novo ficheiro
For i = 2 To lastRow
'cria a logica aqui
'Cells(i, 1) -> coluna do name
wk.Worksheets("Sheet1").Cells(i, 1) = fileOriginal.Cells(i, 2)

'exemplo -> verificar a primeira coluna se é Multimídia > Multilaser
    If fileOriginal.Cells(i, 1) = "Multimídia > Multilaser" Then
         wk.Worksheets("Sheet1").Cells(i, 2) = 1
    Else
        wk.Worksheets("Sheet1").Cells(i, 2) = 2
    End If

'cria aqui a logica
'Estrutura do cells .Cells(#LINHA, #Coluna)
wk.Worksheets("Sheet1").Cells(i, 3) = fileOriginal.Cells(i, 3)
wk.Worksheets("Sheet1").Cells(i, 4) = fileOriginal.Cells(i, 4)
wk.Worksheets("Sheet1").Cells(i, 5) = fileOriginal.Cells(i, 5)
wk.Worksheets("Sheet1").Cells(i, 6) = fileOriginal.Cells(i, 6)
wk.Worksheets("Sheet1").Cells(i, 7) = fileOriginal.Cells(i, 7)
wk.Worksheets("Sheet1").Cells(1, 8) = fileOriginal.Cells(i, 8)

Next

End Sub

Browser other questions tagged excel vba

You are not signed in. Login or sign up in order to post.