Excel MACRO that make variable sheets with conditional information

[marco6325]

I want to create a Macro that I have not been able to find, I explain the desired operation:

The file has the following Sheets:
Sheets "Origin"
DNI"sheets (One sheet for each ID number)

Now in the Origin Sheet in column "A" has the numbers of "DNI",which could be repeated in several rows, since there is varied information foreach DNI, such as visited countries, what I want is for the macro to evaluate the LeafOrigin and copy the countries visited and price of the passage on the sheet with the name of the DNI from cell B39 for the country and c39 for the priceof the passage.

Illustratively the sheet "origin" would be something like this:

Column A Column B Column C
Row 1 DNI #123 Peru 2,000 Pesos
Row2 DNI # 456 Colombia 1,000 Pesos
Row3 DNI # 123 Argentina 3,000 Pesos

The sheet called 123 would have as a result

Column A Column B
Row 39 Peru 2,000 Pesos
Fila40 Argentina 3,000Pesos

The sheet called 456 would have as a result

Column A Column B
Row 39 Colombia 1,000 Pesos

NOTE:they are not only Country and Price, I would have several columns whose information I wanted to pass to the DNI sheet, place only 2 as an example,

Thank you in advance for your support of the area's super experts!

I just Tried wth this:



'Definir objetos a utilizar
Dim wsOrigen As Excel.Worksheet, _
wsDestino As Excel.Worksheet, _
rngOrigen As Excel.Range, _
rngDestino As Excel.Range

'Indicar las hojas de origen y destino
Set wsOrigen = Worksheets("Origen")
Set wsDestino = Worksheets("Destino")

'Indicar la celda de origen y destino
Const celdaOrigen = "Q2"
Const celdaDestino = "C39"

'Inicializar los rangos de origen y destino
Set rngOrigen = wsOrigen.Range(celdaOrigen)
Set rngDestino = wsDestino.Range(celdaDestino)

'Seleccionar rango de celdas origen
Sheets("Origen").Select
rngOrigen.Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy

'Pegar datos en celda destino
rngDestino.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End Sub

[Bob Phillips]

Try this


Public Sub SpreadData()
Dim ws As Worksheet
Dim lastrow As Long
Dim nextrow As Long
Dim i As Long

Application.ScreenUpdating = False

With ActiveWorkbook.Worksheets("Origin")

lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 2 To lastrow

Set ws = wsExists("DNI #" & .Cells(i, "A").Value)
If ws Is Nothing Then

Set ws = ActiveWorkbook.Worksheets.Add(after:=ActiveWorkbook.Worksheets(ActiveWorkbo ok.Worksheets.Count))
ws.Name = "DNI #" & .Cells(i, "A").Value
ws.Range("B1:C1").Value = Array("Country", "Amount") '<<<< extend range and values to suit
End If

nextrow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row + 1
ws.Cells(nextrow, "B").Value = .Cells(i, "B").Value
ws.Cells(nextrow, "C").Value = .Cells(i, "C").Value
'<<<< exted for more columns
Next i
End With

Application.ScreenUpdating = True
End Sub

Private Function wsExists(ByVal wsName As String) As Worksheet
Dim ws As Worksheet

On Error Resume Next
Set ws = ActiveWorkbook.Worksheets(wsName)
On Error GoTo 0

Set wsExists = ws
End Function

[marco6325]

Thank you very much for the quick response, the code works great, the 2 only thing: 1.- The new sheets should be a copy of the sheet called "Model_SES", because tis shees have thecrret fomat, I tried to modify the line of code with "Copy", but it did not work, 2.- If the Macro Run again, the information is duplicated, I need that overwrite the existent data. Might you help me?

[Bob Phillips]

What line with copy, I can't see one. Why would you want to copy Model_SES if you are just extracting data?