Necesito macro de Excel para completar datos de una hoja a otra
Se trata de rellenar la hoja 2 del fichero con los datos (celda de columna de resultados) de la primera hoja. En La hoja 2 podrás ver qué La primera columna contiene los códigos de cada una de las muestras. Necesito completar los elementos para cada código. Para cada elemento (calcio, nitrógeno, etc) se debe de completar con el resultado de cada elemento de la hoja 1 (teniendo en cuenta el código de cada muestra). He completado el resultado para el calcio para el primer código a modo de ejemplo.
No sé si me he explicado bien.
El fichero lo pueden encontrar en este link
https://drive.google.com/file/d/1OLHjb2oCIJj_VFiU8kgx2Do1hzFN1xhb/view?usp=sharing
2 Respuestas
Este es el resultado de la macro
y esta es la macro
Sub copiar_datos_transponer()
Dim funcion As WorksheetFunction
Set funcion = WorksheetFunction
Set h1 = Worksheets("hoja1")
Set h2 = Worksheets("hoja2")
h2.Cells.Clear
Set datos = h1.Range("a1").CurrentRegion
With datos
.Sort key1:=h1.Range("a1"), order1:=xlAscending, _
key2:=h1.Range("a1"), order2:=xlAscending, _
Header:=xlYes
End With
datos.Columns(1).Copy
With h2.Range("a1")
.PasteSpecial xlPasteValues
.CurrentRegion.RemoveDuplicates Columns:=1
End With
datos.Columns(2).Copy
With h2.Range("c3")
.PasteSpecial xlPasteValues
.RemoveDuplicates Columns:=1
filas = .CurrentRegion.Rows.Count
.Rows(2).Resize(filas).Copy
Range("b1").PasteSpecial xlPasteValues, Transpose:=True
.CurrentRegion.Clear
Set tabla = Range("a1").CurrentRegion
End With
With tabla
filas = .Rows.Count: c = .Columns.Count
matriz = tabla
For i = 2 To filas
c_muestra = .Cells(i, 1)
cuenta = funcion.CountIf(datos.Columns(1), c_muestra)
fila = funcion.Match(c_muestra, datos.Columns(1), 0)
Set tabla2 = datos.Rows(fila).Resize(cuenta, 3)
For j = 1 To c
elemento = .Cells(1, j + 1)
cuenta_elemento = funcion.CountIf(tabla2.Columns(2), elemento)
If cuenta_elemento > 0 Then
col = funcion.Match(elemento, tabla2.Columns(2), 0)
resultado = tabla2.Cells(col, 3)
matriz(i, j + 1) = resultado
End If
Next j
Next i
Range(tabla.Address) = matriz
End With
Erase matriz
Set datos = Nothing: Set tabla = Nothing: Set tabla2 = Nothing
Set h1 = Nothing: Set h2 = Nothing: Set funcion = Nothing
End Sub
Proba esta macro haber si te funciona
Sub RutTransponer()
Set H1 = Sheets("hoja 1")
Set h2 = Sheets("hoja 2")
Dim xc1, xc2 As Object
h2.Range("B2:K630").ClearContents
uf = H1.Range("A" & Rows.Count).End(xlUp).Row
x = 2
For Each xc1 In h2.Range("A2:A630")
If Not xc1 Is Nothing Then
y = 2
For fila = 2 To uf
If xc1 = H1.Cells(fila, 1) Then
For Each xc2 In h2.Range("B1:K1")
If xc2 = H1.Cells(fila, 2) Then
h2.Cells(x, y) = H1.Cells(fila, 3)
y = y + 1
End If
Next xc2
End If
Next fila
End If
x = x + 1
Next xc1
End SubPuede que se te cuelgue un poco excel porque tu tienes demaciados datos