A ver si alguien me puede ayudar¡¡ De entrada gracias a todos y perdón por mi ignorancia... soy bastante nueva en estos temas... Después de mucho buscar no sé cómo solucionar el siguiente problema...
He creado una macro... y he conseguido que funcione¡¡¡ es la siguiente
Sub test()
Dim i As Long, j As Long, rw As Long
Dim rng As Range, cel As Range
Dim arrWords
Dim xlCalc As XlCalculation
arrWords = Array("number", "media", "genotype", "user", "experiment", "box", "age", "scale", "root") ' edit the array as required
xlCalc = Application.Calculation
Set rng = Range("c1:c2000")
For rw = rng.Rows(rng.Rows.Count).Row To rng.Rows(1).Row Step -1
For j = 0 To UBound(arrWords)
If InStr(1, rng(rw, 1), arrWords(j), vbTextCompare) Then
bDel = True
rng.Parent.Rows(rw).EntireRow.Delete
Exit For
End If
Next
Next
Application.Calculation = xlCalc
arrWords = Array("vector", "angle") ' edit the array as required
xlCalc = Application.Calculation
Set rng = Range("e1:e2000")
For rw = rng.Rows(rng.Rows.Count).Row To rng.Rows(1).Row Step -1
For j = 0 To UBound(arrWords)
If InStr(1, rng(rw, 1), arrWords(j), vbTextCompare) Then
bDel = True
rng.Parent.Rows(rw).EntireRow.Delete
Exit For
End If
Next
Next
Application.Calculation = xlCalc
Columns("D:D").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
Columns("E:N").Select
Selection.Delete Shift:=xlToLeft
End Sub
Pero ahora no me parece suficiente.. quiero algo más¡¡¡ Me gustaría que esta macro se ejecutara en todos los archivos de una carpeta... pero me gustaría que me preguntara que archivos o que carpeta al menos...
Así que lo intenté de la siguiente manera:
Option Explicit
Sub OpenMultipleUserSelectedFiles()
Dim FileArray As Variant
Dim myBook As Workbook
Dim i As Integer
FileArray = Application.GetOpenFilename(, , "Select the Files", MultiSelect:=True)
If IsArray(FileArray) Then
For i = LBound(FileArray) To UBound(FileArray)
Set myBook = Workbooks.Open(FileArray(i))
Dim i As Long, j As Long, rw As Long
Dim rng As Range, cel As Range
Dim arrWords
Dim xlCalc As XlCalculation
arrWords = Array("number", "media", "genotype", "user", "experiment", "box", "age", "scale", "root") ' edit the array as required
xlCalc = Application.Calculation
Set rng = Range("c1:c2000")
For rw = rng.Rows(rng.Rows.Count).Row To rng.Rows(1).Row Step -1
For j = 0 To UBound(arrWords)
If InStr(1, rng(rw, 1), arrWords(j), vbTextCompare) Then
bDel = True
rng.Parent.Rows(rw).EntireRow.Delete
Exit For
End If
Next
Next
Application.Calculation = xlCalc
arrWords = Array("vector", "angle") ' edit the array as required
xlCalc = Application.Calculation
Set rng = Range("e1:e2000")
For rw = rng.Rows(rng.Rows.Count).Row To rng.Rows(1).Row Step -1
For j = 0 To UBound(arrWords)
If InStr(1, rng(rw, 1), arrWords(j), vbTextCompare) Then
bDel = True
rng.Parent.Rows(rw).EntireRow.Delete
Exit For
End If
Next
Next
Application.Calculation = xlCalc
Columns("D:D").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
Columns("E:N").Select
Selection.Delete Shift:=xlToLeft
myBook.Save
myBook.Close
Next i
Else:
MsgBox "You clicked cancel"
End If
End Sub
Pero esta macro sólo funciona si elimino la parte en azul... dice que hay un error al definir i... lo sé... pero no sé cómo arreglarlo¡¡¡
Seguro que hay alguien por ahí que podría explicarmelo
Muchas gracias
Featured Replies
Archivado
Este tema está ahora archivado y está cerrado a más respuestas.
A ver si alguien me puede ayudar¡¡ De entrada gracias a todos y perdón por mi ignorancia... soy bastante nueva en estos temas... Después de mucho buscar no sé cómo solucionar el siguiente problema...
He creado una macro... y he conseguido que funcione¡¡¡ es la siguiente
Sub test()
Dim i As Long, j As Long, rw As Long
Dim rng As Range, cel As Range
Dim arrWords
Dim xlCalc As XlCalculation
arrWords = Array("number", "media", "genotype", "user", "experiment", "box", "age", "scale", "root") ' edit the array as required
xlCalc = Application.Calculation
Set rng = Range("c1:c2000")
For rw = rng.Rows(rng.Rows.Count).Row To rng.Rows(1).Row Step -1
For j = 0 To UBound(arrWords)
If InStr(1, rng(rw, 1), arrWords(j), vbTextCompare) Then
bDel = True
rng.Parent.Rows(rw).EntireRow.Delete
Exit For
End If
Next
Next
Application.Calculation = xlCalc
arrWords = Array("vector", "angle") ' edit the array as required
xlCalc = Application.Calculation
Set rng = Range("e1:e2000")
For rw = rng.Rows(rng.Rows.Count).Row To rng.Rows(1).Row Step -1
For j = 0 To UBound(arrWords)
If InStr(1, rng(rw, 1), arrWords(j), vbTextCompare) Then
bDel = True
rng.Parent.Rows(rw).EntireRow.Delete
Exit For
End If
Next
Next
Application.Calculation = xlCalc
Columns("D:D").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
Columns("E:N").Select
Selection.Delete Shift:=xlToLeft
End Sub
Pero ahora no me parece suficiente.. quiero algo más¡¡¡ Me gustaría que esta macro se ejecutara en todos los archivos de una carpeta... pero me gustaría que me preguntara que archivos o que carpeta al menos...
Así que lo intenté de la siguiente manera:
Option Explicit
Sub OpenMultipleUserSelectedFiles()
Dim FileArray As Variant
Dim myBook As Workbook
Dim i As Integer
FileArray = Application.GetOpenFilename(, , "Select the Files", MultiSelect:=True)
If IsArray(FileArray) Then
For i = LBound(FileArray) To UBound(FileArray)
Set myBook = Workbooks.Open(FileArray(i))
Dim i As Long, j As Long, rw As Long
Dim rng As Range, cel As Range
Dim arrWords
Dim xlCalc As XlCalculation
arrWords = Array("number", "media", "genotype", "user", "experiment", "box", "age", "scale", "root") ' edit the array as required
xlCalc = Application.Calculation
Set rng = Range("c1:c2000")
For rw = rng.Rows(rng.Rows.Count).Row To rng.Rows(1).Row Step -1
For j = 0 To UBound(arrWords)
If InStr(1, rng(rw, 1), arrWords(j), vbTextCompare) Then
bDel = True
rng.Parent.Rows(rw).EntireRow.Delete
Exit For
End If
Next
Next
Application.Calculation = xlCalc
arrWords = Array("vector", "angle") ' edit the array as required
xlCalc = Application.Calculation
Set rng = Range("e1:e2000")
For rw = rng.Rows(rng.Rows.Count).Row To rng.Rows(1).Row Step -1
For j = 0 To UBound(arrWords)
If InStr(1, rng(rw, 1), arrWords(j), vbTextCompare) Then
bDel = True
rng.Parent.Rows(rw).EntireRow.Delete
Exit For
End If
Next
Next
Application.Calculation = xlCalc
Columns("D:D").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
Columns("E:N").Select
Selection.Delete Shift:=xlToLeft
myBook.Save
myBook.Close
Next i
Else:
MsgBox "You clicked cancel"
End If
End Sub
Pero esta macro sólo funciona si elimino la parte en azul... dice que hay un error al definir i... lo sé... pero no sé cómo arreglarlo¡¡¡
Seguro que hay alguien por ahí que podría explicarmelo
Muchas gracias