VBA to go through some sheets. Copy and Paste it to main sheet(BD)

[pcardenasm]

Hi,
I need some help to copy information from some sheets (only ph to Ortofosfatos,12 sheets) to BD. I've tried for one sheet, but i want to do the same with the other sheets in order, first ph, second Temperatura and so on. In sheet BD should be all the information from the other sheets (manually registered) with its format and must be updated (BD) every time data is entered in the other sheets. Headers in BD are fixed.

Excel file
TEP-EjBD-2023.xlsm

Sub CopyFosforo()
    Dim cont As Long
    Dim ultlinea As Long
    Dim fecha As Date
    Dim muestras As Variant
    Dim analisis As Variant
    Dim parametro As Variant
    Dim tipo As Variant
    Dim metodo As Variant
    Dim influente As Variant
    Dim MEnt As Variant
    Dim MEntf As Variant
    Dim MA As Variant
    Dim MAf As Variant
    Dim MB As Variant
    Dim MBf As Variant
    Dim MC As Variant
    Dim MCf As Variant
    Dim ML As Variant
    Dim MLf As Variant
   
    Dim m As Long
    Dim y As Long
   
    Dim EfluentTerc As Variant
    Dim EfluentTercF As Variant
   
    Dim rango As Variant
     
   
    sheets("Fósforo").Select
    Range("B12").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    sheets("BD").Select
    Range("A3").Select
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
    Range("A3").Select
    sheets("Fósforo").Select
    Application.CutCopyMode = False
    Range("B12").Select
   
    ultlinea = sheets("BD").Range("A" & Rows.Count).End(xlUp).Row
    fila = sheets("Fósforo").Range("B12").End(xlDown).Row
    Set rango = sheets("Fósforo").Range("B12:N" & fila)
   
       
    For cont = 3 To ultlinea
        fecha = sheets("BD").Cells(cont, 1)
        m = Month(fecha)
        y = Year(fecha)
        muestras = Application.VLookup(CLng(CDate(fecha)), rango, 2, False)
        analisis = Application.VLookup(CLng(CDate(fecha)), rango, 3, False)
        parametro = sheets("Fósforo").Name
        tipo = Application.VLookup(CLng(CDate(fecha)), rango, 12, False)
        metodo = Application.VLookup(CLng(CDate(fecha)), rango, 13, False)
       
        EfluentTerc = Application.VLookup(CLng(CDate(fecha)), rango, 5, False)
       
        If Application.WorksheetFunction.IsText(EfluentTerc) Then
            EfluentTercF = Mid(EfluentTerc, 2, 4) / 2
        Else
            EfluentTercF = EfluentTerc
        End If
       
        MEnt = Application.VLookup(CLng(CDate(fecha)), rango, 6, False)
        If Application.WorksheetFunction.IsText(MEnt) Then
            MEntf = Mid(MEnt, 2, 4) / 2
        Else
            MEntf = MEnt
        End If
           
       
        MA = Application.VLookup(CLng(CDate(fecha)), rango, 7, False)
        If Application.WorksheetFunction.IsText(MA) Then
            MAf = Mid(MA, 2, 4) / 2
        Else
            MAf = MA
        End If
       
        MB = Application.VLookup(CLng(CDate(fecha)), rango, 8, False)
        If Application.WorksheetFunction.IsText(MB) Then
            MBf = Mid(MB, 2, 4) / 2
        Else
            MBf = MB
        End If
       
        MC = Application.VLookup(CLng(CDate(fecha)), rango, 9, False)
        If Application.WorksheetFunction.IsText(MC) Then
            MCf = Mid(MC, 2, 4) / 2
        Else
            MCf = MC
        End If
       
               
        ML = Application.VLookup(CLng(CDate(fecha)), rango, 10, False)
        If Application.WorksheetFunction.IsText(ML) Then
            MLf = Mid(ML, 2, 4) / 2
        Else
            MLf = ML
        End If
       
       
        If IsNumeric(MEntf) Then
            influente = MEntf
            If IsEmpty(MEntf) And IsNumeric(EfluentTercF) Then
                influente = EfluentTercF
                If IsEmpty(MEntf) And IsEmpty(EfluentTercF) Then
                    influente = MLf
                End If
            End If
        End If
       
        sheets("BD").Cells(cont, 2) = m
        sheets("BD").Cells(cont, 3) = y
        sheets("BD").Cells(cont, 4) = muestras
        sheets("BD").Cells(cont, 5) = analisis
        sheets("BD").Cells(cont, 6) = parametro
        sheets("BD").Cells(cont, 7) = tipo
        sheets("BD").Cells(cont, 8) = metodo
        sheets("BD").Cells(cont, 9) = influente
        sheets("BD").Cells(cont, 10) = MAf
        sheets("BD").Cells(cont, 11) = MBf
        sheets("BD").Cells(cont, 12) = MCf
        sheets("BD").Cells(cont, 13) = MLf

    Next cont
   
    sheets("BD").Select
    Range("A3").Select
       
 
    MsgBox "Valores de fósforo copiados exitosamente", vbInformation, "Copiar"
   
End Sub

Thanks for considering my request.

Patricia CM

 

[rollis13]

Have a try with these few changes. Note that you have an error (number format) in sheet "Nitrógeno" row "186" column "I".
Please test on a copy of your file.

Option Explicit
Sub CopyFosforo()
    Dim cont As Long
    Dim ultlinea As Long
    Dim fecha As Date
    Dim muestras As Variant
    Dim analisis As Variant
    Dim parametro As Variant
    Dim tipo As Variant
    Dim metodo As Variant
    Dim influente As Variant
    Dim MEnt As Variant
    Dim MEntf As Variant
    Dim MA As Variant
    Dim MAf As Variant
    Dim MB As Variant
    Dim MBf As Variant
    Dim MC As Variant
    Dim MCf As Variant
    Dim ML As Variant
    Dim MLf As Variant
    Dim m As Long
    Dim y As Long
    Dim EfluentTerc As Variant                    'Cuando puede ser texto o número
    Dim EfluentTercF As Variant
    Dim rango As Variant
    Dim fila As Long                              '<- added: wasn't declared
    Dim myArray As Variant                        '<- added: list of sheets with data to be copied (ordered)
    Dim shtName As Variant                        '<- added

    Application.ScreenUpdating = False            '<- added: avoids screen flickering
    myArray = Array("pH", "Temperatura", "Conductividad", "Oxígeno", "Turbidez", "Sólidos en suspensión", "Sólidos Susp. Volatiles", "DQO", "DBO5", "Nitrógeno", "Fósforo", "Ortofosfatos")
    For Each shtName In myArray                   '<- added: loop on all sheets listed in myArray
        '<- changed: from here to end changed all "Fósforo" to shtName
        Sheets(shtName).Select
        Range("B12").Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
        Sheets("BD").Select
        Range("A3").Select
        Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Range("A3").Select
        Sheets(shtName).Select
        Application.CutCopyMode = False
        Range("B12").Select
        ultlinea = Sheets("BD").Range("A" & Rows.Count).End(xlUp).Row
        fila = Sheets(shtName).Range("B12").End(xlDown).Row 'última fila de la hoja a copiar
        Set rango = Sheets(shtName).Range("B12:N" & fila) 'define el rango de la hoja a copiar
        For cont = 3 To ultlinea
            fecha = Sheets("BD").Cells(cont, 1)
            m = Month(fecha)
            y = Year(fecha)
            muestras = Application.VLookup(CLng(CDate(fecha)), rango, 2, False)
            analisis = Application.VLookup(CLng(CDate(fecha)), rango, 3, False)
            parametro = Sheets(shtName).Name
            tipo = Application.VLookup(CLng(CDate(fecha)), rango, 12, False)
            metodo = Application.VLookup(CLng(CDate(fecha)), rango, 13, False)
            EfluentTerc = Application.VLookup(CLng(CDate(fecha)), rango, 5, False)
            If Application.WorksheetFunction.IsText(EfluentTerc) Then
                EfluentTercF = Mid(EfluentTerc, 2, 4) / 2
            Else
                EfluentTercF = EfluentTerc
            End If
            MEnt = Application.VLookup(CLng(CDate(fecha)), rango, 6, False)
            If Application.WorksheetFunction.IsText(MEnt) Then
                MEntf = Mid(MEnt, 2, 4) / 2
            Else
                MEntf = MEnt
            End If
            MA = Application.VLookup(CLng(CDate(fecha)), rango, 7, False)
            If Application.WorksheetFunction.IsText(MA) Then
                MAf = Mid(MA, 2, 4) / 2
            Else
                MAf = MA
            End If
            MB = Application.VLookup(CLng(CDate(fecha)), rango, 8, False)
            If Application.WorksheetFunction.IsText(MB) Then
                MBf = Mid(MB, 2, 4) / 2
            Else
                MBf = MB
            End If
            MC = Application.VLookup(CLng(CDate(fecha)), rango, 9, False)
            If Application.WorksheetFunction.IsText(MC) Then
                MCf = Mid(MC, 2, 4) / 2
            Else
                MCf = MC
            End If
            ML = Application.VLookup(CLng(CDate(fecha)), rango, 10, False)
            If Application.WorksheetFunction.IsText(ML) Then
                MLf = Mid(ML, 2, 4) / 2
            Else
                MLf = ML
            End If
            If IsNumeric(MEntf) Then
                influente = MEntf
                If IsEmpty(MEntf) And IsNumeric(EfluentTercF) Then
                    influente = EfluentTercF
                    If IsEmpty(MEntf) And IsEmpty(EfluentTercF) Then influente = MLf
                End If
            End If
            Sheets("BD").Cells(cont, 2) = m
            Sheets("BD").Cells(cont, 3) = y
            Sheets("BD").Cells(cont, 4) = muestras
            Sheets("BD").Cells(cont, 5) = analisis
            Sheets("BD").Cells(cont, 6) = parametro
            Sheets("BD").Cells(cont, 7) = tipo
            Sheets("BD").Cells(cont, 8) = metodo
            Sheets("BD").Cells(cont, 9) = influente
            Sheets("BD").Cells(cont, 10) = MAf
            Sheets("BD").Cells(cont, 11) = MBf
            Sheets("BD").Cells(cont, 12) = MCf
            Sheets("BD").Cells(cont, 13) = MLf
        Next cont
    Next shtName                                  '<- added
    Application.ScreenUpdating = True             '<- added
    Sheets("BD").Select
    Range("A3").Select
    MsgBox "Valores copiados exitosamente", vbInformation, "Copiar" '<- changed
End Sub

 

[pcardenasm]

Thank you for your answer. I tried with your suggestion, in the main sheet (BD) all the data was copied only from the last sheet (Ortofosfatos). Additionally, in "Fecha" column (BD), the range of values ("Fecha" column) from the "Conductividad" sheet was copied below the data from "Ortofosfatos" sheet, generating #N/A values in BD sheet.

TEP-EjBD-2023_solucion.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M
2	Fecha	Mes	Año	Muestras	Análisis	Parámetro	Tipo de muestra	Método	Influente	MA	MB	MC	ML
3	15/01/2014	1	2014	UPV	UPV	Ortofosfatos	Puntual		0.014	0.023	0.017	0.017	0.014
4	05/02/2014	2	2014	UPV	UPV	Ortofosfatos	Puntual		0.008	0.005	0.012	0.005	0.008
5	26/02/2014	2	2014	UPV	UPV	Ortofosfatos	Puntual		0.005	0.005	0.005	0.005	0.005
6	12/03/2014	3	2014	UPV	UPV	Ortofosfatos	Puntual		0.009	0.005	0.010	0.005	0.009
7	02/04/2014	4	2014	UPV	UPV	Ortofosfatos	Puntual		0.005	0.008	0.005	0.005	0.005
8	24/04/2014	4	2014	UPV	UPV	Ortofosfatos	Puntual		0.005	0.005	0.005	0.005	0.005
9	14/05/2014	5	2014	UPV	UPV	Ortofosfatos	Puntual		0.005	0.005	0.010	0.005	0.005
10	04/06/2014	6	2014	UPV	UPV	Ortofosfatos	Puntual		0.006	0.005	0.006	0.005	0.006
11	25/06/2014	6	2014	UPV	UPV	Ortofosfatos	Puntual		0.005	0.006	0.015	0.005	0.005
12	16/07/2014	7	2014	UPV	UPV	Ortofosfatos	Puntual		0.005	0.005	0.017	0.005	0.005
13	30/07/2014	7	2014	UPV	UPV	Ortofosfatos	Puntual		0.026	0.015	0.012	0.005	0.026
14	27/08/2014	8	2014	UPV	UPV	Ortofosfatos	Puntual		0.005	0.005	0.005	0.005	0.005
15	24/09/2014	9	2014	UPV	UPV	Ortofosfatos	Puntual		0.005	0.005	0.005	0.005	0.005
16	15/10/2014	10	2014	UPV	UPV	Ortofosfatos	Puntual		0.005	0.005	0.005	0.035	0.005
17	29/10/2014	10	2014	UPV	UPV	Ortofosfatos	Puntual		0.005	0.005	0.005	0.005	0.005
18	19/11/2014	11	2014	UPV	UPV	Ortofosfatos	Puntual		0.005	0.005	0.005	0.005	0.005
19	11/12/2014	12	2014	UPV	UPV	Ortofosfatos	Puntual		0.009	0.005	0.005	0.005	0.009
20	07/01/2015	1	2015	UPV	UPV	Ortofosfatos	Puntual		0.005	0.005	0.005	0.005	0.005
21	26/01/2015	1	2015	UPV	UPV	Ortofosfatos	Puntual		0.005	0.005	0.005	0.005	0.005
22	11/02/2015	2	2015	UPV	UPV	Ortofosfatos	Puntual		0.005	0.005	0.008	0.005	0.005
23	04/03/2015	3	2015	UPV	UPV	Ortofosfatos	Puntual		0.005	0.005	0.008	0.005	0.005
24	25/03/2015	3	2015	UPV	UPV	Ortofosfatos	Puntual		0.005	0.005	0.005	0.005	0.005
25	20/04/2015	4	2015	UPV	UPV	Ortofosfatos	Puntual		0.005	0.005	0.009	0.005	0.005
26	06/05/2015	5	2015	UPV	UPV	Ortofosfatos	Puntual		0.005	0.005	0.006	0.005	0.005
27	27/05/2015	5	2015	UPV	UPV	Ortofosfatos	Puntual		0.005	0.005	0.005	0.005	0.005
28	17/06/2015	6	2015	UPV	UPV	Ortofosfatos	Puntual		0.005	0.005	0.005	0.005	0.005
29	08/07/2015	7	2015	UPV	UPV	Ortofosfatos	Puntual		0.005	0.005	0.005	0.005	0.005
30	29/07/2015	7	2015	UPV	UPV	Ortofosfatos	Puntual		0.005	0.029	0.010	0.005	0.005
31	26/08/2015	8	2015	UPV	UPV	Ortofosfatos	Puntual		0.005	0.044	0.005	0.005	0.005
32	17/09/2015	9	2015	UPV	UPV	Ortofosfatos	Puntual		0.005	0.009	0.005	0.005	0.005
33	07/10/2015	10	2015	UPV	UPV	Ortofosfatos	Puntual		0.005	0.005	0.005	0.005	0.005
34	21/10/2015	10	2015	UPV	UPV	Ortofosfatos	Puntual		0.005	0.005	0.005	0.005	0.005
35	11/11/2015	11	2015	UPV	UPV	Ortofosfatos	Puntual		0.005	0.005	0.005	0.005	0.005
36	02/12/2015	12	2015	UPV	UPV	Ortofosfatos	Puntual		0.005	0.009	0.005	0.005	0.005
37	23/12/2015	12	2015	UPV	UPV	Ortofosfatos	Puntual		0.005	0.005	0.005	0.005	0.005
38	26/01/2016	1	2016	UPV	UPV	Ortofosfatos	Puntual		0.024			0.005	0.024
39	24/02/2016	2	2016	UPV	UPV	Ortofosfatos	Puntual		0.005			0.010	0.005
40	22/03/2016	3	2016	UPV	UPV	Ortofosfatos	Puntual		0.005			0.005	0.005
41	26/04/2016	4	2016	UPV	UPV	Ortofosfatos	Puntual		0.005			0.005	0.005
42	25/05/2016	5	2016	UPV	UPV	Ortofosfatos	Puntual		0.004			0.007	0.004
43	21/06/2016	6	2016	UPV	UPV	Ortofosfatos	Puntual		0.016			0.005	0.016
44	26/07/2016	7	2016	UPV	UPV	Ortofosfatos	Puntual		0.003			0.002	0.003
45	30/08/2016	8	2016	UPV	UPV	Ortofosfatos	Puntual		0.005			0.054	0.005
46	29/09/2016	9	2016	UPV	UPV	Ortofosfatos	Puntual		0.008			0.023	0.008
47	26/10/2016	10	2016	UPV	UPV	Ortofosfatos	Puntual		0.034			0.005	0.034
48	30/11/2016	11	2016	UPV	UPV	Ortofosfatos	Puntual		0.010			0.017	0.010
49	13/03/2017	3	2017	Analaqua	Analaqua	Ortofosfatos	Puntual	Espectofotometría (valor menor de 0.15 fuera de acreditación)	0.003			0.004	0.003
50	29/03/2017	3	2017	Analaqua	Analaqua	Ortofosfatos	Puntual	Espectofotometría (valor menor de 0.15 fuera de acreditación)	0.008			0.008	0.008
51	19/04/2017	4	2017	Analaqua	Analaqua	Ortofosfatos	Puntual	Espectofotometría (valor menor de 0.15 fuera de acreditación)	0.023			0.025	0.023
52	17/05/2017	5	2017	Analaqua	Analaqua	Ortofosfatos	Puntual	Espectofotometría (valor menor de 0.15 fuera de acreditación)	0.080			0.063	0.080
53	14/06/2017	6	2017	Analaqua	Analaqua	Ortofosfatos	Puntual	Espectofotometría (valor menor de 0.15 fuera de acreditación)	0.010			0.016	0.010
54	12/07/2017	7	2017	Analaqua	Analaqua	Ortofosfatos	Puntual	Espectofotometría (valor menor de 0.15 fuera de acreditación)	0.000			0.000	0.000
55	21/08/2017	8	2017	Analaqua	Analaqua	Ortofosfatos	Puntual	Espectofotometría (valor menor de 0.15 fuera de acreditación)	0.000			0.000	0.000
56	13/09/2017	9	2017	Analaqua	Analaqua	Ortofosfatos	Puntual	Espectofotometría (valor menor de 0.15 fuera de acreditación)	0.005			0.005	0.005
57	11/10/2017	10	2017	Analaqua	Analaqua	Ortofosfatos	Puntual	Espectofotometría (valor menor de 0.15 fuera de acreditación)	0.026			0.017	0.026
58	15/11/2017	11	2017	Analaqua	Analaqua	Ortofosfatos	Puntual	Espectofotometría (valor menor de 0.15 fuera de acreditación)	0.023			0.018	0.023
59	19/12/2017	12	2017	Analaqua	Analaqua	Ortofosfatos	Puntual	Espectofotometría (valor menor de 0.15 fuera de acreditación)	0.016			0.007	0.016
60	17/01/2018	1	2018	Analaqua	Analaqua	Ortofosfatos	Puntual	Espectofotometría (valor menor de 0.15 fuera de acreditación)	0.031			0.018	0.031
61	22/05/2018	5	2018	Analaqua	Analaqua	Ortofosfatos	Puntual	Espectofotometría (valor menor de 0.15 fuera de acreditación)	0.050	0.015		0.015	0.050
62	26/06/2018	6	2018	Analaqua	Analaqua	Ortofosfatos	Puntual	Espectofotometría (valor menor de 0.15 fuera de acreditación)	0.015	0.015		0.015	0.015
63	24/07/2018	7	2018	Analaqua	Analaqua	Ortofosfatos	Puntual	Espectofotometría (valor menor de 0.15 fuera de acreditación)	0.015	0.015		0.015	0.015
64	28/08/2018	8	2018	Analaqua	Analaqua	Ortofosfatos	Puntual	Espectofotometría (valor menor de 0.15 fuera de acreditación)	0.015	0.015		0.015	0.015
65	24/09/2018	9	2018	Analaqua	Analaqua	Ortofosfatos	Puntual	Espectofotometría (valor menor de 0.15 fuera de acreditación)	0.015	0.015		0.015	0.015
66	23/10/2018	10	2018	Analaqua	Analaqua	Ortofosfatos	Puntual	Espectofotometría (valor menor de 0.15 fuera de acreditación)	0.015	0.015		0.015	0.015
67	27/11/2018	11	2018	Analaqua	Analaqua	Ortofosfatos	Puntual	Espectofotometría (valor menor de 0.15 fuera de acreditación)	0.015	0.015		0.015	0.015
68	18/12/2018	12	2018	Analaqua	Analaqua	Ortofosfatos	Puntual	Espectofotometría (valor menor de 0.15 fuera de acreditación)	0.015	0.015		0.015	0.015
69	24/01/2019	1	2019	Analaqua	Analaqua	Ortofosfatos	Puntual	Espectofotometría (valor menor de 0.15 fuera de acreditación)	0.015	0.015		0.015	0.015
70	26/02/2019	2	2019	Analaqua	Analaqua	Ortofosfatos	Puntual	Espectofotometría (valor menor de 0.15 fuera de acreditación)	0.015	0.015		0.015	0.015
71	26/03/2019	3	2019	Analaqua	Analaqua	Ortofosfatos	Puntual	Espectofotometría (valor menor de 0.15 fuera de acreditación)	0.015	0.015		0.015	0.015
72	26/04/2019	4	2019	Analaqua	Analaqua	Ortofosfatos	Puntual	Espectofotometría (valor menor de 0.15 fuera de acreditación)	0.060			0.015	0.060
73	03/06/2019	6	2019	Analaqua	Analaqua	Ortofosfatos	Puntual	Espectofotometría (valor menor de 0.15 fuera de acreditación)	0.170	0.140		0.015	0.015
74	25/06/2019	6	2019	Analaqua	Analaqua	Ortofosfatos	Puntual	Espectofotometría (valor menor de 0.15 fuera de acreditación)	0.040	0.090		0.015	0.015
75	30/07/2019	7	2019	Analaqua	Analaqua	Ortofosfatos	Puntual	Espectofotometría (valor menor de 0.15 fuera de acreditación)	0.400	0.170		0.100	0.030
76	02/10/2019	10	2019	LTL	LTL	Ortofosfatos
77	10/10/2019	10	2019	LTL	LTL	Ortofosfatos
78	17/10/2019	10	2019	LTL	LTL	Ortofosfatos
79	23/10/2019	10	2019	LTL	LTL	Ortofosfatos
80	30/10/2019	10	2019	LTL	LTL	Ortofosfatos			0.123	0.101		0.025	0.184
81	05/11/2019	11	2019	LTL	LTL	Ortofosfatos
82	13/11/2019	11	2019	LTL	LTL	Ortofosfatos
83	20/11/2019	11	2019	LTL	LTL	Ortofosfatos
84	27/11/2019	11	2019	LTL	LTL	Ortofosfatos			0.131	0.132	0.025	0.025	0.131
85	03/12/2019	12	2019	LTL	LTL	Ortofosfatos
86	11/12/2019	12	2019	LTL	LTL	Ortofosfatos
87	18/12/2019	12	2019	LTL	LTL	Ortofosfatos
88	24/12/2019	12	2019	LTL	LTL	Ortofosfatos			0.025	0.025		0.025	0.117
89	30/12/2019	12	2019	LTL	LTL	Ortofosfatos
90	08/01/2020	1	2020	LTL	LTL	Ortofosfatos
91	14/01/2020	1	2020	LTL	LTL	Ortofosfatos
92	24/01/2020	1	2020	LTL	LTL	Ortofosfatos
93	28/01/2020	1	2020	LTL	LTL	Ortofosfatos			0.025	0.097		0.025	0.025
94	04/02/2020	2	2020	LTL	LTL	Ortofosfatos
95	12/02/2020	2	2020	LTL	LTL	Ortofosfatos
96	19/02/2020	2	2020	LTL	LTL	Ortofosfatos			0.152	0.162		0.025	0.154
97	27/02/2020	2	2020	LTL	LTL	Ortofosfatos
98	03/03/2020	3	2020	LTL	LTL	Ortofosfatos
99	11/03/2020	3	2020	LTL	LTL	Ortofosfatos
100	17/03/2020	3	2020	LTL	LTL	Ortofosfatos			0.310	0.235		0.148	0.025
BD

 

[rollis13]

You weren't erasing the target area in the 'BD' sheet and I didn't notice. Here's an updated version with a bit of cleanup of useless lines of code (from Macro Recorder). Take another test.

Option Explicit
Sub CopyFosforo()
    Dim cont As Long
    Dim ultlinea As Long
    Dim fecha As Date
    Dim muestras As Variant
    Dim analisis As Variant
    Dim parametro As Variant
    Dim tipo As Variant
    Dim metodo As Variant
    Dim influente As Variant
    Dim MEnt As Variant
    Dim MEntf As Variant
    Dim MA As Variant
    Dim MAf As Variant
    Dim MB As Variant
    Dim MBf As Variant
    Dim MC As Variant
    Dim MCf As Variant
    Dim ML As Variant
    Dim MLf As Variant
    Dim m As Long
    Dim y As Long
    Dim EfluentTerc As Variant                    'Cuando puede ser texto o número
    Dim EfluentTercF As Variant
    Dim rango As Variant
    Dim fila As Long                              '<- added: wasn't declared
    Dim myArray As Variant                        '<- added: list of sheets with data to be copied (ordered)
    Dim shtName As Variant                        '<- added
    Dim firstRow As Long                          '<- added2

    Application.ScreenUpdating = False            '<- added: avoids screen flickering
    firstRow = 3                                  '<- added2
    ultlinea = Sheets("BD").Range("A" & Rows.Count).End(xlUp).Row '<- added2
    If ultlinea < 3 Then ultlinea = 3             '<- added2
    Sheets("BD").Range("A3:M" & ultlinea).ClearContents '<- added2
    myArray = Array("pH", "Temperatura", "Conductividad", "Oxígeno", "Turbidez", "Sólidos en suspensión", "Sólidos Susp. Volatiles", "DQO", "DBO5", "Nitrógeno", "Fósforo", "Ortofosfatos")
    For Each shtName In myArray                   '<- added: loop on all sheets listed in myArray
        '<- changed: from here to end changed all "Fósforo" to shtName
        Sheets(shtName).Select
        'Range("B12").Select
        Range(Range("B12"), Range("B12").End(xlDown)).Copy '<- changed2
        'Sheets("BD").Select
        'Range("A" & firstRow).Select
        'Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Sheets("BD").Range("A" & firstRow).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False '<- changed2
        'Range("A3").Select
        'Sheets(shtName).Select
        'Application.CutCopyMode = False
        'Range("B12").Select
        ultlinea = Sheets("BD").Range("A" & Rows.Count).End(xlUp).Row
        fila = Sheets(shtName).Range("B12").End(xlDown).Row 'última fila de la hoja a copiar
        Set rango = Sheets(shtName).Range("B12:N" & fila) 'define el rango de la hoja a copiar
        For cont = firstRow To ultlinea           '<- changed2
            fecha = Sheets("BD").Cells(cont, 1)
            m = Month(fecha)
            y = Year(fecha)
            muestras = Application.VLookup(CLng(CDate(fecha)), rango, 2, False)
            analisis = Application.VLookup(CLng(CDate(fecha)), rango, 3, False)
            parametro = Sheets(shtName).Name
            tipo = Application.VLookup(CLng(CDate(fecha)), rango, 12, False)
            metodo = Application.VLookup(CLng(CDate(fecha)), rango, 13, False)
            EfluentTerc = Application.VLookup(CLng(CDate(fecha)), rango, 5, False)
            If Application.WorksheetFunction.IsText(EfluentTerc) Then
                EfluentTercF = Mid(EfluentTerc, 2, 4) / 2
            Else
                EfluentTercF = EfluentTerc
            End If
            MEnt = Application.VLookup(CLng(CDate(fecha)), rango, 6, False)
            If Application.WorksheetFunction.IsText(MEnt) Then
                MEntf = Mid(MEnt, 2, 4) / 2
            Else
                MEntf = MEnt
            End If
            MA = Application.VLookup(CLng(CDate(fecha)), rango, 7, False)
            If Application.WorksheetFunction.IsText(MA) Then
                MAf = Mid(MA, 2, 4) / 2
            Else
                MAf = MA
            End If
            MB = Application.VLookup(CLng(CDate(fecha)), rango, 8, False)
            If Application.WorksheetFunction.IsText(MB) Then
                MBf = Mid(MB, 2, 4) / 2
            Else
                MBf = MB
            End If
            MC = Application.VLookup(CLng(CDate(fecha)), rango, 9, False)
            If Application.WorksheetFunction.IsText(MC) Then
                MCf = Mid(MC, 2, 4) / 2
            Else
                MCf = MC
            End If
            ML = Application.VLookup(CLng(CDate(fecha)), rango, 10, False)
            If Application.WorksheetFunction.IsText(ML) Then
                MLf = Mid(ML, 2, 4) / 2
            Else
                MLf = ML
            End If
            If IsNumeric(MEntf) Then
                influente = MEntf
                If IsEmpty(MEntf) And IsNumeric(EfluentTercF) Then
                    influente = EfluentTercF
                    If IsEmpty(MEntf) And IsEmpty(EfluentTercF) Then influente = MLf
                End If
            End If
            Sheets("BD").Cells(cont, 2) = m
            Sheets("BD").Cells(cont, 3) = y
            Sheets("BD").Cells(cont, 4) = muestras
            Sheets("BD").Cells(cont, 5) = analisis
            Sheets("BD").Cells(cont, 6) = parametro
            Sheets("BD").Cells(cont, 7) = tipo
            Sheets("BD").Cells(cont, 8) = metodo
            Sheets("BD").Cells(cont, 9) = influente
            Sheets("BD").Cells(cont, 10) = MAf
            Sheets("BD").Cells(cont, 11) = MBf
            Sheets("BD").Cells(cont, 12) = MCf
            Sheets("BD").Cells(cont, 13) = MLf
        Next cont
        firstRow = ultlinea + 1                   '<- added2
        Application.CutCopyMode = False           '<- moved2
    Next shtName                                  '<- added
    Application.ScreenUpdating = True             '<- added
    Sheets("BD").Select
    Range("A3").Select
    MsgBox "Valores copiados exitosamente", vbInformation, "Copiar" '<- changed
End Sub

 

[pcardenasm]

Hi!! It works very well !!!! I really appreciate your help.

 

[rollis13]

Thanks for the positive feedback, glad having been of some help.

 

[pcardenasm]

Hi again ,
I realized in some sheets are duplicated values for the same date, I used an expression to count them in each sheet (column A)
I tried to use INDEX and MATCH (two criteria) with new created ranges, but it doesn't work. Or maybe i should use another function?

TEP-EjBD-F.RevB.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N
136	1	18/09/2020	Intercontrol Levante S.A.	Intercontrol Levante S.A.	1,950	1,950							Compuesta	MEN-LMA-016
137	1	24/09/2020	Intercontrol Levante S.A.	Intercontrol Levante S.A.		1,850							Puntual	MEN-LMA-016
138	2	24/09/2020	Intercontrol Levante S.A.	Intercontrol Levante S.A.		2,050							Compuesta	MEN-LMA-016
139	3	24/09/2020	Intercontrol Levante S.A.	Intercontrol Levante S.A.		1,850							Puntual	MEN-LMA-016
140	4	24/09/2020	Intercontrol Levante S.A.	Intercontrol Levante S.A.	2,070	2,050	1,270	1,270		1,920	1,140		Compuesta + Puntual	MEN-LMA-016 + MEN-LMA-057
141	1	01/10/2020	Intercontrol Levante S.A.	Intercontrol Levante S.A.	2,120	2,130							Compuesta	MEN-LMA-016
142	1	08/10/2020	Intercontrol Levante S.A.	Intercontrol Levante S.A.	2,090	2,090							Compuesta	MEN-LMA-016
143	1	15/10/2020	Intercontrol Levante S.A.	Intercontrol Levante S.A.	2,090	2,130	1,840	1,850		2,300	1,630		Compuesta + Puntual	MEN-LMA-016 + MEN-LMA-057
144	1	22/10/2020	Intercontrol Levante S.A.	Intercontrol Levante S.A.	2,070	2,060							Compuesta	MEN-LMA-016
145	2	22/10/2020	Intercontrol Levante S.A.	Intercontrol Levante S.A.		1,870							Puntual	MEN-LMA-016
146	1	27/10/2020	Intercontrol Levante S.A.	Intercontrol Levante S.A.	2,100	2,080							Compuesta	MEN-LMA-016
147	1	04/11/2020	Intercontrol Levante S.A.	Intercontrol Levante S.A.	2,010	2,010							Compuesta	MEN-LMA-016
148	1	13/11/2020	Intercontrol Levante S.A.	Intercontrol Levante S.A.	812								Compuesta	MEN-LMA-016
149	1	20/11/2020	Intercontrol Levante S.A.	Intercontrol Levante S.A.	894								Compuesta	MEN-LMA-016
150	1	24/11/2020	Intercontrol Levante S.A.	Intercontrol Levante S.A.	889								Compuesta	MEN-LMA-016
151	1	04/12/2020	Intercontrol Levante S.A.	Intercontrol Levante S.A.	971	1,230							Compuesta	MEN-LMA-016
152	1	11/12/2020	Intercontrol Levante S.A.	Intercontrol Levante S.A.	2,050	1,990							Compuesta	MEN-LMA-016
153	1	17/12/2020	Intercontrol Levante S.A.	Intercontrol Levante S.A.	2,090	2,090	1,850	1,700		2,500	1,250		Compuesta + Puntual	MEN-LMA-016 + MEN-LMA-057
154	2	17/12/2020	Intercontrol Levante S.A.	Intercontrol Levante S.A.		1,880							Puntual	MEN-LMA-016
155	1	23/12/2020	Intercontrol Levante S.A.	Intercontrol Levante S.A.		1,840							Puntual	MEN-LMA-016
156	2	23/12/2020	Intercontrol Levante S.A.	Intercontrol Levante S.A.	1,930	2,020							Compuesta	MEN-LMA-016
157	1	29/12/2020	Intercontrol Levante S.A.	Intercontrol Levante S.A.	1,940	1,930							Compuesta	MEN-LMA-016
Conductividad

Cell Formulas
Range	Formula
A136:A157	A136	=COUNTIF($B$12:B136,B136)

Option Explicit
Sub CopyFosforo()
    Dim cont As Long
    Dim ultlinea As Long
    Dim fecha As Date
    Dim muestras As Variant
    Dim analisis As Variant
    Dim parametro As Variant
    Dim tipo As Variant
    Dim metodo As Variant
    Dim influente As Variant
    Dim MEnt As Variant
    Dim MEntf As Variant
    Dim MA As Variant
    Dim MAf As Variant
    Dim MB As Variant
    Dim MBf As Variant
    Dim MC As Variant
    Dim MCf As Variant
    Dim ML As Variant
    Dim MLf As Variant
    Dim m As Long
    Dim y As Long
    Dim EfluentTerc As Variant                    'Cuando puede ser texto o número
    Dim EfluentTercF As Variant
    Dim rango As Variant
    Dim fila As Long                              '<- added: wasn't declared
    Dim myArray As Variant                        '<- added: list of sheets with data to be copied (ordered)
    Dim shtName As Variant                        '<- added
    Dim firstRow As Long                          '<- added2

    Dim MAf2 As Variant
    
    Dim contador As Long

    Dim rngfecha As Range           'added dic23
    Dim rngcont As Range            'added dic23
    Dim rngmuest As Range           'added dic23

    Application.ScreenUpdating = False            '<- added: avoids screen flickering
    firstRow = 3                                  '<- added2
    ultlinea = sheets("BD").Range("A" & Rows.Count).End(xlUp).Row '<- added2
    If ultlinea < 3 Then ultlinea = 3             '<- added2
    sheets("BD").Range("A3:O" & ultlinea).ClearContents '<- added2
    myArray = Array("pH", "Temperatura", "Conductividad", "Oxígeno", "Turbidez", "Sólidos en suspensión", "Sólidos Susp. Volatiles", "DQO", "DBO5", "Nitrógeno", "Fósforo", "Ortofosfatos")
    For Each shtName In myArray                   '<- added: loop on all sheets listed in myArray
        '<- changed: from here to end changed all "Fósforo" to shtName
        sheets(shtName).Select
        'Range("B12").Select
        Range(Range("A12:B12"), Range("A12:B12").End(xlDown)).Copy '<- changed2
        'Sheets("BD").Select
        'Range("A" & firstRow).Select
        'Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        sheets("BD").Range("A" & firstRow).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False '<- changed2
        'Range("A3").Select
        'Sheets(shtName).Select
        'Application.CutCopyMode = False
        'Range("B12").Select
        ultlinea = sheets("BD").Range("A" & Rows.Count).End(xlUp).Row
        fila = sheets(shtName).Range("B12").End(xlDown).Row 'última fila de la hoja a copiar
        
        Set rango = sheets(shtName).Range("B12:N" & fila) 'define el rango de la hoja a copiar
        
        Set rngcont = sheets(shtName).Range("A12:A" & fila)     'added dic23
        Set rngfecha = sheets(shtName).Range("B12:B" & fila)    'added dic23
        Set rngmuest = sheets(shtName).Range("C12:C" & fila)    'added dic23
        
        For cont = firstRow To ultlinea           '<- changed2
            contador = sheets("BD").Cells(cont, 1)              'added dic23
            fecha = sheets("BD").Cells(cont, 2)
            m = Month(fecha)
            y = Year(fecha)
            muestras = Application.Index(rngmuest, Application.Match(contador & CLng(CDate(fecha)), rngcont & rngfecha, 0)) 'it doesn't work
            
            'i want to do the same for these expressions
            analisis = Application.VLookup(CLng(CDate(fecha)), rango, 3, False)
            parametro = sheets(shtName).Name
            tipo = Application.VLookup(CLng(CDate(fecha)), rango, 12, False)
            metodo = Application.VLookup(CLng(CDate(fecha)), rango, 13, False)
            EfluentTerc = Application.VLookup(CLng(CDate(fecha)), rango, 5, False)
            If Application.WorksheetFunction.IsText(EfluentTerc) Then
                EfluentTercF = Mid(EfluentTerc, 2, 4) / 2
            Else
                EfluentTercF = EfluentTerc
            End If
            MEnt = Application.VLookup(CLng(CDate(fecha)), rango, 6, False)
            If Application.WorksheetFunction.IsText(MEnt) Then
                MEntf = Mid(MEnt, 2, 4) / 2
            Else
                MEntf = MEnt
            End If
            MA = Application.VLookup(CLng(CDate(fecha)), rango, 7, False)
            If Application.WorksheetFunction.IsText(MA) Then
                MAf = Mid(MA, 2, 4) / 2
            Else
                MAf = MA
            End If
            MB = Application.VLookup(CLng(CDate(fecha)), rango, 8, False)
            If Application.WorksheetFunction.IsText(MB) Then
                MBf = Mid(MB, 2, 4) / 2
            Else
                MBf = MB
            End If
            MC = Application.VLookup(CLng(CDate(fecha)), rango, 9, False)
            If Application.WorksheetFunction.IsText(MC) Then
                MCf = Mid(MC, 2, 4) / 2
            Else
                MCf = MC
            End If
            ML = Application.VLookup(CLng(CDate(fecha)), rango, 10, False)
            If Application.WorksheetFunction.IsText(ML) Then
                MLf = Mid(ML, 2, 4) / 2
            Else
                MLf = ML
            End If
            
            
            
            If IsNumeric(MEntf) Then
                influente = MEntf
                If IsEmpty(MEntf) And IsNumeric(EfluentTercF) Then
                    influente = EfluentTercF
                    If IsEmpty(MEntf) And IsEmpty(EfluentTercF) Then influente = MLf
                End If
            End If
            
            
            If IsNumeric(MAf) Then
            
                MAf2 = Format(Round(MAf, 2), "#,##0.00")
            
                If IsEmpty(MAf) Then
                    MAf2 = ""
                End If
            End If
            

            
            sheets("BD").Cells(cont, 3) = m
            sheets("BD").Cells(cont, 4) = y
            sheets("BD").Cells(cont, 5) = muestras
            sheets("BD").Cells(cont, 6) = analisis
            sheets("BD").Cells(cont, 7) = parametro
            sheets("BD").Cells(cont, 8) = tipo
            sheets("BD").Cells(cont, 9) = metodo
            sheets("BD").Cells(cont, 10) = EfluentTercF
            sheets("BD").Cells(cont, 11) = influente
            sheets("BD").Cells(cont, 12) = MAf2
            sheets("BD").Cells(cont, 13) = MBf
            sheets("BD").Cells(cont, 14) = MCf
            sheets("BD").Cells(cont, 15) = MLf
        
        Next cont
        firstRow = ultlinea + 1                   '<- added2
        Application.CutCopyMode = False           '<- moved2
    Next shtName                                  '<- added
    Application.ScreenUpdating = True             '<- added
    sheets("BD").Select
    Range("A3").Select
    MsgBox "Valores copiados exitosamente", vbInformation, "Copiar" '<- changed
End Sub

Thank you.