Adicionar línea a macro para limitar extracción
Seria posible adicionar una línea que indique hasta que columna debe leer la macro que ud. Creo.
Anexo macro:
Sub Importar_Datos() ' ' Por.Dante Amor ' ' Set l1 = ThisWorkbook Set h1 = l1.Sheets("Valores") Set h2 = l1.Sheets("Resumen") h2.Cells.ClearContents ' ruta = h1.[B5] hoja = h1.[B6] fila = h1.[B7] colu = h1.[B8] ' mensaje = validaciones(ruta, hoja, fila, colu) If mensaje <> "" Then MsgBox mensaje, vbExclamation, "IMPORTAR ARCHIVOS" Exit Sub End If ' Application.ScreenUpdating = False Application.DisplayAlerts = False Application.StatusBar = False Application.Calculation = xlCalculationManual ' If Right(ruta, 1) <> "\" Then ruta = ruta & "\" arch = Dir(ruta & "*.xls*") i = 0 Do While arch <> "" i = i + 1 Application.StatusBar = "Importando Libro : " & i & " de : " & n Set l2 = Workbooks.Open(ruta & arch) existe = False If IsNumeric(hoja) Then If l2.Sheets.Count >= hoja Then existe = True Set h22 = l2.Sheets(hoja) Else End If Else For Each h In l2.Sheets If LCase(h.Name) = LCase(hoja) Then existe = True Set h22 = l2.Sheets(hoja) Exit For End If Next End If ' If existe Then u22 = h22.Range(colu & Rows.Count).End(xlUp).Row u2 = h2.Range("A" & Rows.Count).End(xlUp).Row + 1 h22.Rows(fila & ":" & u22).Copy h2.Range("A" & u2).PasteSpecial xlValues End If ' l2.Close False arch = Dir() Loop ' Application.ScreenUpdating = True Application.DisplayAlerts = True Application.StatusBar = False Application.Calculation = xlCalculationAutomatic ' MsgBox "Proceso terminado, archivos importados a la hoja resumen", vbInformation, "IMPORTAR ARCHIVOS" End Sub