Guardar archivo creando una carpeta en un directorio con el nombre de la celda A1 y dar nombre al archivo con celda B1

Quiero guardar archivo creando una carpeta en un directorio con el nombre de la celda A1 y dar nombre al archivo con celda B1 seria esto posible

1 Respuesta

Respuesta
2

[Ho la y bienvenido a todoexpertos!

Puedes poner ejemplos, algo como esto:

- Tienes un directorio: "C:\trabajo\"

En ese directorio quieres crear la carpeta que está en la celda A1

- En la celda A1 tienes el dato "componentes"

- En la celda B1 tienes el dato "alternador"

- Cuál archivo vas a guardar, la hoja activa, el libro activo, una copia del libro con la macro, puede ser más específico.

Suponiendo lo anterior y que vas a guardar una copia del archivo que contiene la macro:

Sub GuardarArchivo()
  'Por Dante Amor
  Dim sPath As String, sFold As String, sFile
  '
  sPath = "C:\trabajo\"   'ajusta al nombre de tu directorio
  sFold = Range("A1").Value
  sFile = Range("B1").Value
  '
  If Dir(sPath, vbDirectory) = "" Then
    MsgBox "No existe el directorio"
    Exit Sub
  End If
  '
  If Dir(sPath & sFold, vbDirectory) = "" Then
    MkDir (sPath & sFold)
  End If
  '
  ThisWorkbook.SaveCopyAs sPath & sFold & "\" & sFile & ".xlsm"
  MsgBox "Archivo guardado"
End Sub

[Al final hay un botón para valorar (es como un like a mi respuesta)

[Si tienes dudas puedes comentar o explica con más detalle qué necesitas y actualizo la macro.

Tengo un Libro  en directorio: "C:\preparacion\"con las macros el cual abre un archivo en un directorio: "C:\trabajo\" despues tengo varias macros que realizan distintas funciones en el archivo abierto y para guardar el archivo despues de ser tratado que lo guarde con los datos introducidos en las celdas dentro del archivo con las macros o que dicha macro al ser llamada al final de los procesos anteriores pida por el nombre de carpeta a crear y pida por el nombre a dar al archivo a guardar, espero me entiendas con estas indicaciones.

- En la celda A1 el dato para dar  "NombreCarpeta"

- En la celda B1 el dato para dar  "NombreArchivo"

Tengo mucho que agradecer ya que con vosotros aprendo mucho :) y Dante Amor eres un Maquina del tema. Saludos Juan Perez desde Nürnberg Alemania

Pon aquí la macro con la que abres el libro.

Tienes un archivo con macros, en ese archivo tienes una hoja con estos datos:

- En la celda A1 el dato para dar "NombreCarpeta"

- En la celda B1 el dato para dar "NombreArchivo"

¿Cómo se llama esa hoja?

Este es el nombre del libro de macros JuanPerez_Excel_Macros se que es un desastre y un rompecabezas muy grande que me gustaría hacerlo funcionar con menos parches y menos código estas son las macros.

Sub Eliminar_Filas()
'Por.Dante Amor
'Workbooks.Open Filename:= _
"W:\OTTO\02_Kleine Geräte\Klein Geräte Liste Prototype.xlsx"
Workbooks.Open Filename:= _
"F:\NeuerKunde\Klein Geräte Liste Prototype.xlsx"
Sheets("Unter 100€ (Sortierte Ware)").Select 'nombre de la hoja con la información
'ActiveSheet.ShowAllData
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
col = "H" 'columna para aplicar la condición
'texto de la condición
'Para una fecha: "10/07/2017" el formato debe ser dd/mm/aaaa
'Para un número: "123"
texto = "0"
'
valor = texto
If IsNumeric(texto) Then valor = Val(texto)
If IsDate(texto) Then valor = CDate(texto)
'
'Application.ScreenUpdating = True
Application.ScreenUpdating = False
For i = Range(col & Rows.Count).End(xlUp).Row To 1 Step -1
If LCase(Cells(i, "H")) = LCase(valor) Then
Rows(i).Delete
Range("F:F,L:L").Select
'Range("L1").Activate
Selection.Delete Shift:=xlToLeft
Range("A3").Select
End If
Next
Sheets("Sortierte Ware").Select
'ActiveSheet.ShowAllData
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
col = "H" 'columna para aplicar la condición
'texto de la condición
'Para una fecha: "10/07/2017" el formato debe ser dd/mm/aaaa
'Para un número: "123"
texto = "0"
'
valor = texto
If IsNumeric(texto) Then valor = Val(texto)
If IsDate(texto) Then valor = CDate(texto)
'
'Application.ScreenUpdating = False
For i = Range(col & Rows.Count).End(xlUp).Row To 1 Step -1
If LCase(Cells(i, "H")) = LCase(valor) Then
Rows(i).Delete
Range("F:F,L:L").Select
Range("L1").Activate
Selection.Delete Shift:=xlToLeft
End If
Next
Sheets("Unsortiert").Select
'ActiveSheet.ShowAllData
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
col = "H" 'columna para aplicar la condición
'texto de la condición
'Para una fecha: "10/07/2017" el formato debe ser dd/mm/aaaa
'Para un número: "123"
texto = "0"
'
valor = texto
If IsNumeric(texto) Then valor = Val(texto)
If IsDate(texto) Then valor = CDate(texto)
'
'Application.ScreenUpdating = False
For i = Range(col & Rows.Count).End(xlUp).Row To 1 Step -1
If LCase(Cells(i, "H")) = LCase(valor) Then
Rows(i).Delete
End If
Next
Sheets("Sortierte Ware").Select
'ActiveSheet.ShowAllData
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
col = "H" 'columna para aplicar la condición
'texto de la condición
'Para una fecha: "10/07/2017" el formato debe ser dd/mm/aaaa
'Para un número: "123"
texto = "0"
'
valor = texto
If IsNumeric(texto) Then valor = Val(texto)
If IsDate(texto) Then valor = CDate(texto)
'
'Application.ScreenUpdating = False
For i = Range(col & Rows.Count).End(xlUp).Row To 1 Step -1
If LCase(Cells(i, "H")) = LCase(valor) Then
Rows(i).Delete
End If
Next
Sheets("Unsortiert").Select
'ActiveSheet.ShowAllData
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
Columns("F:F").Select 'columna para aplicar borrado de formulas
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
col = "F" 'columna para aplicar la condición
'texto de la condición
'Para una fecha: "10/07/2017" el formato debe ser dd/mm/aaaa
'Para un número: "123"
texto = "verkauft"
'
valor = texto
If IsNumeric(texto) Then valor = Val(texto)
If IsDate(texto) Then valor = CDate(texto)
'
'Application.ScreenUpdating = False
For i = Range(col & Rows.Count).End(xlUp).Row To 1 Step -1
If LCase(Cells(i, "F")) = LCase(valor) Then
Rows(i).Delete
ActiveWindow.ScrollRow = 3 'volver al pricipio
Range("F1").Select
End If
Next
Sheets("Personal Verkauf").Select
'ActiveSheet.ShowAllData
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
Columns("F:F").Select 'columna para aplicar borrado de formulas
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
col = "F" 'columna para aplicar la condición
'texto de la condición
'Para una fecha: "10/07/2017" el formato debe ser dd/mm/aaaa
'Para un número: "123"
texto = "verkauft"
'
valor = texto
If IsNumeric(texto) Then valor = Val(texto)
If IsDate(texto) Then valor = CDate(texto)
'
'Application.ScreenUpdating = False
For i = Range(col & Rows.Count).End(xlUp).Row To 1 Step -1
If LCase(Cells(i, "F")) = LCase(valor) Then
Rows(i).Delete
ActiveWindow.ScrollRow = 3 'volver al pricipio
Range("F1").Select
End If
Next
Call eliminarcolumnas 'llamar macro para eliminar columna
Call eliminarcolumnas2
Call EliminarColumnas3
Call GuardarArchivo
'Windows("Klein Geräte Liste Prototype.xlsx").Activate
'ActiveWorkbook.SaveAs Filename:= _
"W:\OTTO\02_Kleine Geräte\Angebot für Kunde\Klein Geräte Liste Prototype_ElvinciGmbH.xlsx" _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
'ChDir "C:\Users\j.perez\Desktop\KUNDEN ANGEBOT\NeuerKunde"
'ActiveWorkbook.SaveAs Filename:= _
"C:\Users\j.perez\Desktop\KUNDEN ANGEBOT\NeuerKunde\Klein Geräte Liste Ejemplo.xlsx" _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
'Windows("JuanPerez_Excel_Macros.xlsm").Activate
'ActiveWindow.Close
'Range("I4").Select
'Application.ScreenUpdating = True
MsgBox "Zeilen gelöscht und Datei im Ordner gespeichert W:\OTTO\02_Kleine Geräte\Angebot für Kunde\Klein Geräte Liste Prototype_ElvinciGmbH.xlsx ", vbInformation, "Juan Perez"
End Sub

Sub eliminarcolumnas()
'
' eliminarcolumnas Macro
' eliminarcolumnas
'Call eliminarcolumnas
' Acceso directo: CTRL+h
'
Sheets("Unter 100€ (Sortierte Ware)").Select
'ActiveSheet.ShowAllData
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
Columns("G:G").Select 'columna para aplicar borrado de formulas
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
col = "G" 'columna para aplicar la condición
'texto de la condición
'Para una fecha: "10/07/2017" el formato debe ser dd/mm/aaaa
'Para un número: "123"
texto = "0"
'
valor = texto
If IsNumeric(texto) Then valor = Val(texto)
If IsDate(texto) Then valor = CDate(texto)
'
Application.ScreenUpdating = False
For i = Range(col & Rows.Count).End(xlUp).Row To 1 Step -1
If LCase(Cells(i, "G")) = LCase(valor) Then
Rows(i).Delete
ActiveWindow.ScrollRow = 3 'volver al pricipio
Range("G1").Select
End If
Next
End Sub

Sub eliminarcolumnas2()
'
' eliminarcolumnas Macro
' eliminarcolumnas
'Call eliminarcolumnas2
' Acceso directo: CTRL+j
'
Sheets("Sortierte Ware").Select
'ActiveSheet.ShowAllData
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
Columns("G:G").Select 'columna para aplicar borrado de formulas
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
col = "G" 'columna para aplicar la condición
'texto de la condición
'Para una fecha: "10/07/2017" el formato debe ser dd/mm/aaaa
'Para un número: "123"
texto = "0"
'
valor = texto
If IsNumeric(texto) Then valor = Val(texto)
If IsDate(texto) Then valor = CDate(texto)
'
Application.ScreenUpdating = False
For i = Range(col & Rows.Count).End(xlUp).Row To 1 Step -1
If LCase(Cells(i, "G")) = LCase(valor) Then
Rows(i).Delete
ActiveWindow.ScrollRow = 3 'volver al pricipio
Range("G1").Select
End If
Next
End Sub

Sub EliminarColumnas3()
'
' EliminarColumnas3 Macro
' EliminarColumnas3
'

'
Sheets("Dyson").Select
Range("H:H").Select
Selection.Delete Shift:=xlToLeft
Range("H1").Select
Sheets("Personal Verkauf").Select
Range("I:I,K:K,N:N,O:O").Select
Selection.Delete Shift:=xlToLeft
Range("O1").Select
Sheets("Unsortiert").Select
Range("I:I,K:K,L:L,N:N,O:O").Select
Selection.Delete Shift:=xlToLeft
Range("O1").Select
Sheets("Unter 100€ (Sortierte Ware)").Select
End Sub

Sub GuardarArchivo()
  'Por Dante Amor
  Dim sPath As String, sFold As String, sFile
  '
  sPath = "C:\trabajo\"   'ajusta al nombre de tu directorio
  sFold = Range("A1").Value
  sFile = Range("B1").Value
  '
  If Dir(sPath, vbDirectory) = "" Then
    MsgBox "No existe el directorio"
    Exit Sub
  End If
  '
  If Dir(sPath & sFold, vbDirectory) = "" Then
    MkDir (sPath & sFold)
  End If
  '
  ThisWorkbook.SaveCopyAs sPath & sFold & "\" & sFile & ".xlsm"
  MsgBox "Archivo guardado"
End Sub

En lo sucesivo, cuando pongas una macro aquí en el foro debes utilizar el icono para insertar código. En la siguiente imagen te muestro en dónde está el icono para que lo utilices.

Observa la diferencia:

Sin icono:

Sub GuardarArchivo()
'Por Dante Amor
Dim sPath As String, sFold As String, sFile
sPath = "C:\trabajo\" 'ajusta al nombre de tu directorio
sFold = Range("A1").Value
sFile = Range("B1").Value
End Sub

Con icono:

Sub GuardarArchivo()
  'Por Dante Amor
  Dim sPath As String, sFold As String, sFile
  '
  sPath = "C:\trabajo\"   'ajusta al nombre de tu directorio
  sFold = Range("A1").Value
  sFile = Range("B1").Value
End Sub

Tienes varias macros.

¿Cómo se llama la macro que abre el archivo?

No contestaste esta duda:

Tienes un archivo con macros, en ese archivo tienes una hoja con estos datos:
- En la celda A1 el dato para dar "NombreCarpeta"
- En la celda B1 el dato para dar "NombreArchivo"
¿Cómo se llama esa hoja?

El nombre de la hoja en el libro de macros es "Tabelle1" en español "Hoja1" 

Sub Eliminar_Filas()
'Por.Dante Amor
     'Workbooks.Open Filename:= _
        "W:\OTTO\02_Kleine Geräte\Klein Geräte Liste Prototype.xlsx"
    Workbooks.Open Filename:= _
        "F:\NeuerKunde\Klein Geräte Liste Prototype.xlsx"
    Sheets("Unter 100€ (Sortierte Ware)").Select 'nombre de la hoja con la información
    'ActiveSheet.ShowAllData
     If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
    col = "H"                   'columna para aplicar la condición
    'texto de la condición
        'Para una fecha: "10/07/2017" el formato debe ser dd/mm/aaaa
        'Para un número: "123"
    texto = "0"
    '
    valor = texto
    If IsNumeric(texto) Then valor = Val(texto)
    If IsDate(texto) Then valor = CDate(texto)
    '
    'Application.ScreenUpdating = True
    Application.ScreenUpdating = False
    For i = Range(col & Rows.Count).End(xlUp).Row To 1 Step -1
        If LCase(Cells(i, "H")) = LCase(valor) Then
            Rows(i).Delete
            Range("F:F,L:L").Select
    'Range("L1").Activate
    Selection.Delete Shift:=xlToLeft
    Range("A3").Select
        End If
    Next
    Sheets("Sortierte Ware").Select
    'ActiveSheet.ShowAllData
     If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
    col = "H"                   'columna para aplicar la condición
    'texto de la condición
        'Para una fecha: "10/07/2017" el formato debe ser dd/mm/aaaa
        'Para un número: "123"
    texto = "0"
    '
    valor = texto
    If IsNumeric(texto) Then valor = Val(texto)
    If IsDate(texto) Then valor = CDate(texto)
    '
    'Application.ScreenUpdating = False
    For i = Range(col & Rows.Count).End(xlUp).Row To 1 Step -1
        If LCase(Cells(i, "H")) = LCase(valor) Then
            Rows(i).Delete
            Range("F:F,L:L").Select
    Range("L1").Activate
    Selection.Delete Shift:=xlToLeft
        End If
    Next
    Sheets("Unsortiert").Select
    'ActiveSheet.ShowAllData
     If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
    col = "H"                   'columna para aplicar la condición
    'texto de la condición
        'Para una fecha: "10/07/2017" el formato debe ser dd/mm/aaaa
        'Para un número: "123"
    texto = "0"
    '
    valor = texto
    If IsNumeric(texto) Then valor = Val(texto)
    If IsDate(texto) Then valor = CDate(texto)
    '
    'Application.ScreenUpdating = False
    For i = Range(col & Rows.Count).End(xlUp).Row To 1 Step -1
        If LCase(Cells(i, "H")) = LCase(valor) Then
            Rows(i).Delete
        End If
    Next
    Sheets("Sortierte Ware").Select
    'ActiveSheet.ShowAllData
     If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
    col = "H"                   'columna para aplicar la condición
    'texto de la condición
        'Para una fecha: "10/07/2017" el formato debe ser dd/mm/aaaa
        'Para un número: "123"
    texto = "0"
    '
    valor = texto
    If IsNumeric(texto) Then valor = Val(texto)
    If IsDate(texto) Then valor = CDate(texto)
    '
    'Application.ScreenUpdating = False
    For i = Range(col & Rows.Count).End(xlUp).Row To 1 Step -1
        If LCase(Cells(i, "H")) = LCase(valor) Then
            Rows(i).Delete
        End If
    Next
    Sheets("Unsortiert").Select
    'ActiveSheet.ShowAllData
     If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
    Columns("F:F").Select 'columna para aplicar borrado de formulas
    Application.CutCopyMode = False
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    col = "F"                   'columna para aplicar la condición
    'texto de la condición
        'Para una fecha: "10/07/2017" el formato debe ser dd/mm/aaaa
        'Para un número: "123"
    texto = "verkauft"
    '
    valor = texto
    If IsNumeric(texto) Then valor = Val(texto)
    If IsDate(texto) Then valor = CDate(texto)
    '
    'Application.ScreenUpdating = False
    For i = Range(col & Rows.Count).End(xlUp).Row To 1 Step -1
        If LCase(Cells(i, "F")) = LCase(valor) Then
            Rows(i).Delete
            ActiveWindow.ScrollRow = 3 'volver al pricipio
            Range("F1").Select
        End If
    Next
    Sheets("Personal Verkauf").Select
    'ActiveSheet.ShowAllData
     If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
    Columns("F:F").Select 'columna para aplicar borrado de formulas
    Application.CutCopyMode = False
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    col = "F"                   'columna para aplicar la condición
    'texto de la condición
        'Para una fecha: "10/07/2017" el formato debe ser dd/mm/aaaa
        'Para un número: "123"
    texto = "verkauft"
    '
    valor = texto
    If IsNumeric(texto) Then valor = Val(texto)
    If IsDate(texto) Then valor = CDate(texto)
    '
    'Application.ScreenUpdating = False
    For i = Range(col & Rows.Count).End(xlUp).Row To 1 Step -1
        If LCase(Cells(i, "F")) = LCase(valor) Then
            Rows(i).Delete
            ActiveWindow.ScrollRow = 3 'volver al pricipio
            Range("F1").Select
        End If
    Next
    Call eliminarcolumnas 'llamar macro para eliminar columna
    Call eliminarcolumnas2
    Call EliminarColumnas3
    Call GuardarArchivo
    'Windows("Klein Geräte Liste Prototype.xlsx").Activate
    'ActiveWorkbook.SaveAs Filename:= _
        "W:\OTTO\02_Kleine Geräte\Angebot für Kunde\Klein Geräte Liste Prototype_ElvinciGmbH.xlsx" _
        , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    'ChDir "C:\Users\j.perez\Desktop\KUNDEN ANGEBOT\NeuerKunde"
    'ActiveWorkbook.SaveAs Filename:= _
        "C:\Users\j.perez\Desktop\KUNDEN ANGEBOT\NeuerKunde\Klein Geräte Liste Ejemplo.xlsx" _
        , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    'Windows("JuanPerez_Excel_Macros.xlsm").Activate
    'ActiveWindow.Close
    'Range("I4").Select
    'Application.ScreenUpdating = True
    MsgBox "Zeilen gelöscht und Datei im Ordner gespeichert W:\OTTO\02_Kleine Geräte\Angebot für Kunde\Klein Geräte Liste Prototype_ElvinciGmbH.xlsx ", vbInformation, "Juan Perez"
End Sub
Sub eliminarcolumnas()
'
' eliminarcolumnas Macro
' eliminarcolumnas
'Call eliminarcolumnas
' Acceso directo: CTRL+h
'
     Sheets("Unter 100€ (Sortierte Ware)").Select
    'ActiveSheet.ShowAllData
     If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
    Columns("G:G").Select 'columna para aplicar borrado de formulas
    Application.CutCopyMode = False
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    col = "G"                   'columna para aplicar la condición
    'texto de la condición
        'Para una fecha: "10/07/2017" el formato debe ser dd/mm/aaaa
        'Para un número: "123"
    texto = "0"
    '
    valor = texto
    If IsNumeric(texto) Then valor = Val(texto)
    If IsDate(texto) Then valor = CDate(texto)
    '
    Application.ScreenUpdating = False
    For i = Range(col & Rows.Count).End(xlUp).Row To 1 Step -1
        If LCase(Cells(i, "G")) = LCase(valor) Then
            Rows(i).Delete
            ActiveWindow.ScrollRow = 3 'volver al pricipio
            Range("G1").Select
        End If
    Next
End Sub
Sub eliminarcolumnas2()
'
' eliminarcolumnas Macro
' eliminarcolumnas
'Call eliminarcolumnas2
' Acceso directo: CTRL+j
'
     Sheets("Sortierte Ware").Select
    'ActiveSheet.ShowAllData
     If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
    Columns("G:G").Select 'columna para aplicar borrado de formulas
    Application.CutCopyMode = False
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    col = "G"                   'columna para aplicar la condición
    'texto de la condición
        'Para una fecha: "10/07/2017" el formato debe ser dd/mm/aaaa
        'Para un número: "123"
    texto = "0"
    '
    valor = texto
    If IsNumeric(texto) Then valor = Val(texto)
    If IsDate(texto) Then valor = CDate(texto)
    '
    Application.ScreenUpdating = False
    For i = Range(col & Rows.Count).End(xlUp).Row To 1 Step -1
        If LCase(Cells(i, "G")) = LCase(valor) Then
            Rows(i).Delete
            ActiveWindow.ScrollRow = 3 'volver al pricipio
            Range("G1").Select
        End If
    Next
End Sub
Sub EliminarColumnas3()
'
' EliminarColumnas3 Macro
' EliminarColumnas3
'
'
    Sheets("Dyson").Select
    Range("H:H").Select
    Selection.Delete Shift:=xlToLeft
    Range("H1").Select
    Sheets("Personal Verkauf").Select
    Range("I:I,K:K,N:N,O:O").Select
    Selection.Delete Shift:=xlToLeft
    Range("O1").Select
    Sheets("Unsortiert").Select
    Range("I:I,K:K,L:L,N:N,O:O").Select
    Selection.Delete Shift:=xlToLeft
    Range("O1").Select
    Sheets("Unter 100€ (Sortierte Ware)").Select
End Sub
Sub GuardarArchivo()
  'Por Dante Amor W:\OTTO\02_Kleine Geräte\Angebot für Kunde\
  Dim sPath As String, sFold As String, sFile
  '
  sPath = "F:\NeuerKunde"   'ajusta al nombre de tu directorio
  sFold = Range("A1").Value
  sFile = Range("B1").Value
  '
  If Dir(sPath, vbDirectory) = "" Then
    MsgBox "No existe el directorio"
    Exit Sub
  End If
  '
  If Dir(sPath & sFold, vbDirectory) = "" Then
    MkDir (sPath & sFold)
  End If
  '
  'ThisWorkbook.SaveCopyAs sPath & sFold & "\" & sFile & ".xlsm"
  ActiveWorkbook.SaveCopyAs sPath & sFold & "\" & sFile & ".xlsm"
  MsgBox "Archivo guardado"
End Sub

estas son las macros que necesito poder corregir o agrupar y que funcione

En la macro "Eliminar_Filas", después de estas líneas:

    '****************
    'Guardar Archivo
    '****************

Agregué el código para guardar la macro:

Sub Eliminar_Filas()
'Por.Dante Amor
     'Workbooks.Open Filename:= _
        "W:\OTTO\02_Kleine Geräte\Klein Geräte Liste Prototype.xlsx"
    Workbooks.Open Filename:= _
        "F:\NeuerKunde\Klein Geräte Liste Prototype.xlsx"
    Sheets("Unter 100€ (Sortierte Ware)").Select 'nombre de la hoja con la información
    'ActiveSheet.ShowAllData
     If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
    col = "H"                   'columna para aplicar la condición
    'texto de la condición
        'Para una fecha: "10/07/2017" el formato debe ser dd/mm/aaaa
        'Para un número: "123"
    texto = "0"
    '
    valor = texto
    If IsNumeric(texto) Then valor = Val(texto)
    If IsDate(texto) Then valor = CDate(texto)
    '
    'Application.ScreenUpdating = True
    Application.ScreenUpdating = False
    For i = Range(col & Rows.Count).End(xlUp).Row To 1 Step -1
        If LCase(Cells(i, "H")) = LCase(valor) Then
            Rows(i).Delete
            Range("F:F,L:L").Select
    'Range("L1").Activate
    Selection.Delete Shift:=xlToLeft
    Range("A3").Select
        End If
    Next
    Sheets("Sortierte Ware").Select
    'ActiveSheet.ShowAllData
     If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
    col = "H"                   'columna para aplicar la condición
    'texto de la condición
        'Para una fecha: "10/07/2017" el formato debe ser dd/mm/aaaa
        'Para un número: "123"
    texto = "0"
    '
    valor = texto
    If IsNumeric(texto) Then valor = Val(texto)
    If IsDate(texto) Then valor = CDate(texto)
    '
    'Application.ScreenUpdating = False
    For i = Range(col & Rows.Count).End(xlUp).Row To 1 Step -1
        If LCase(Cells(i, "H")) = LCase(valor) Then
            Rows(i).Delete
            Range("F:F,L:L").Select
    Range("L1").Activate
    Selection.Delete Shift:=xlToLeft
        End If
    Next
    Sheets("Unsortiert").Select
    'ActiveSheet.ShowAllData
     If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
    col = "H"                   'columna para aplicar la condición
    'texto de la condición
        'Para una fecha: "10/07/2017" el formato debe ser dd/mm/aaaa
        'Para un número: "123"
    texto = "0"
    '
    valor = texto
    If IsNumeric(texto) Then valor = Val(texto)
    If IsDate(texto) Then valor = CDate(texto)
    '
    'Application.ScreenUpdating = False
    For i = Range(col & Rows.Count).End(xlUp).Row To 1 Step -1
        If LCase(Cells(i, "H")) = LCase(valor) Then
            Rows(i).Delete
        End If
    Next
    Sheets("Sortierte Ware").Select
    'ActiveSheet.ShowAllData
     If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
    col = "H"                   'columna para aplicar la condición
    'texto de la condición
        'Para una fecha: "10/07/2017" el formato debe ser dd/mm/aaaa
        'Para un número: "123"
    texto = "0"
    '
    valor = texto
    If IsNumeric(texto) Then valor = Val(texto)
    If IsDate(texto) Then valor = CDate(texto)
    '
    'Application.ScreenUpdating = False
    For i = Range(col & Rows.Count).End(xlUp).Row To 1 Step -1
        If LCase(Cells(i, "H")) = LCase(valor) Then
            Rows(i).Delete
        End If
    Next
    Sheets("Unsortiert").Select
    'ActiveSheet.ShowAllData
     If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
    Columns("F:F").Select 'columna para aplicar borrado de formulas
    Application.CutCopyMode = False
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    col = "F"                   'columna para aplicar la condición
    'texto de la condición
        'Para una fecha: "10/07/2017" el formato debe ser dd/mm/aaaa
        'Para un número: "123"
    texto = "verkauft"
    '
    valor = texto
    If IsNumeric(texto) Then valor = Val(texto)
    If IsDate(texto) Then valor = CDate(texto)
    '
    'Application.ScreenUpdating = False
    For i = Range(col & Rows.Count).End(xlUp).Row To 1 Step -1
        If LCase(Cells(i, "F")) = LCase(valor) Then
            Rows(i).Delete
            ActiveWindow.ScrollRow = 3 'volver al pricipio
            Range("F1").Select
        End If
    Next
    Sheets("Personal Verkauf").Select
    'ActiveSheet.ShowAllData
     If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
    Columns("F:F").Select 'columna para aplicar borrado de formulas
    Application.CutCopyMode = False
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    col = "F"                   'columna para aplicar la condición
    'texto de la condición
        'Para una fecha: "10/07/2017" el formato debe ser dd/mm/aaaa
        'Para un número: "123"
    texto = "verkauft"
    '
    valor = texto
    If IsNumeric(texto) Then valor = Val(texto)
    If IsDate(texto) Then valor = CDate(texto)
    '
    'Application.ScreenUpdating = False
    For i = Range(col & Rows.Count).End(xlUp).Row To 1 Step -1
        If LCase(Cells(i, "F")) = LCase(valor) Then
            Rows(i).Delete
            ActiveWindow.ScrollRow = 3 'volver al pricipio
            Range("F1").Select
        End If
    Next
    Call eliminarcolumnas 'llamar macro para eliminar columna
    Call eliminarcolumnas2
    Call EliminarColumnas3
    '****************
    'Guardar Archivo
    '****************
    '
    Dim sPath As String, sFold As String, sFile
    '
    sPath = "F:\NeuerKunde\"   'ajusta al nombre de tu directorio
    sFold = Sheets("Tabelle1").Range("A1").Value
    sFile = Sheets("Tabelle1").Range("B1").Value
    '
    If Dir(sPath, vbDirectory) = "" Then
      MsgBox "No existe el directorio " & sPath
      Exit Sub
    End If
    '
    If Dir(sPath & sFold, vbDirectory) = "" Then
      MkDir (sPath & sFold)
    End If
    '
    Windows("Klein Geräte Liste Prototype.xlsx").Activate
    ActiveWorkbook.SaveCopyAs sPath & sFold & "\" & sFile & ".xlsm"
    '
    MsgBox "Zeilen gelöscht und Datei im Ordner gespeichert W:\OTTO\02_Kleine Geräte\Angebot für Kunde\Klein Geräte Liste Prototype_ElvinciGmbH.xlsx ", vbInformation, "Juan Perez"
End Sub
'
Sub eliminarcolumnas()
'
' eliminarcolumnas Macro
' eliminarcolumnas
'Call eliminarcolumnas
' Acceso directo: CTRL+h
'
     Sheets("Unter 100€ (Sortierte Ware)").Select
    'ActiveSheet.ShowAllData
     If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
    Columns("G:G").Select 'columna para aplicar borrado de formulas
    Application.CutCopyMode = False
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    col = "G"                   'columna para aplicar la condición
    'texto de la condición
        'Para una fecha: "10/07/2017" el formato debe ser dd/mm/aaaa
        'Para un número: "123"
    texto = "0"
    '
    valor = texto
    If IsNumeric(texto) Then valor = Val(texto)
    If IsDate(texto) Then valor = CDate(texto)
    '
    Application.ScreenUpdating = False
    For i = Range(col & Rows.Count).End(xlUp).Row To 1 Step -1
        If LCase(Cells(i, "G")) = LCase(valor) Then
            Rows(i).Delete
            ActiveWindow.ScrollRow = 3 'volver al pricipio
            Range("G1").Select
        End If
    Next
End Sub
Sub eliminarcolumnas2()
'
' eliminarcolumnas Macro
' eliminarcolumnas
'Call eliminarcolumnas2
' Acceso directo: CTRL+j
'
     Sheets("Sortierte Ware").Select
    'ActiveSheet.ShowAllData
     If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
    Columns("G:G").Select 'columna para aplicar borrado de formulas
    Application.CutCopyMode = False
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    col = "G"                   'columna para aplicar la condición
    'texto de la condición
        'Para una fecha: "10/07/2017" el formato debe ser dd/mm/aaaa
        'Para un número: "123"
    texto = "0"
    '
    valor = texto
    If IsNumeric(texto) Then valor = Val(texto)
    If IsDate(texto) Then valor = CDate(texto)
    '
    Application.ScreenUpdating = False
    For i = Range(col & Rows.Count).End(xlUp).Row To 1 Step -1
        If LCase(Cells(i, "G")) = LCase(valor) Then
            Rows(i).Delete
            ActiveWindow.ScrollRow = 3 'volver al pricipio
            Range("G1").Select
        End If
    Next
End Sub
Sub EliminarColumnas3()
'
' EliminarColumnas3 Macro
' EliminarColumnas3
'
'
    Sheets("Dyson").Select
    Range("H:H").Select
    Selection.Delete Shift:=xlToLeft
    Range("H1").Select
    Sheets("Personal Verkauf").Select
    Range("I:I,K:K,N:N,O:O").Select
    Selection.Delete Shift:=xlToLeft
    Range("O1").Select
    Sheets("Unsortiert").Select
    Range("I:I,K:K,L:L,N:N,O:O").Select
    Selection.Delete Shift:=xlToLeft
    Range("O1").Select
    Sheets("Unter 100€ (Sortierte Ware)").Select
End Sub

Eres el mejor y lo digo de corazón por que te mereces el reconocimiento por tu rapidez y el buen hacer estoy impresionado. Siento las faltas de ortografía estoy con teclado Alemán

No es necesario activar el libro con la macro:

Cambia a esto:

    sFold = ThisWorkbook.Sheets("Tabelle1").Range("A1").Value
    sFile = ThisWorkbook.Sheets("Tabelle1").Range("B1").Value

En el libro con la macro debes tener una hoja con el nombre "Tabelle1" y en las celda A1 el folder y en la B1 el nombre.

¡Gracias! Eres único funciona de maravilla y me quede sin elogios para agradecerte tu labor.

crea la carpeta y el archivo pero no lo puedo abrir me da este error

En la celda B1 debes poner el nombre con extensión ".xlsx"

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas

Macro abrir archivo en la carpeta con el nombre que introduzca en una ventana

Ahora tengo un código que me abre un excel de una carpeta, en función del nombre que inserto en una celda. El codigo es este: Sub Pori_y_Salo() ' ' abrir pori Dim File As String Dim sPath sPath = ThisWorkbook.Path & "\" Sheets("Total").Activate sFile...
2 respuestas

Cambiar celda para uso de autofiltro en visual basic

Tengo este código Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address(False, False) = "B2" Then Application.ScreenUpdating = False ActiveSheet.Unprotect "28021990" If ActiveSheet.FilterMode Then ShowAllData Application.EnableEvents...
1 respuesta

Formulario vba que con dos condiciones inserte datos en columnas

Estoy intentando hacer un formulario, pero ando muuuy perdido. Pretendo que busque en la hoja tabla calendario la fila que contenga la fecha y el empleado indicado en el formulario e ingrese en la columna correspondiente los datos siguientes; en la...
1 respuesta

Aplicar fórmula por Macro Según la creación de nuevas Columnas

Tengo una columna donde tengo que calcular la diferencia entre otras dos columnas automáticamente. El detalle esta en que estas columnas varían de acuerdo al mes. Es decir el usuario agrega más columnas y la fórmula tiene que cambiar a través de un...
1 respuesta

Incluir en macro existen una instruccion de busqueda

Quisiera que me ayudaras con la siguiente macro que ya tengo. Sub GrabarPacienteNuevo() Range("D10") = UCase(Range("D10")) Range("D13") = UCase(Range("D13")) Range("D18") = UCase(Range("D18")) Range("D16") = LCase(Range("D16"))...
1 respuesta

Cómo establecer un valor límite en la división de un rango de valores

La siguiente macro nos permite ingresar un valor máximo para dividir un rango y copiar los valores únicos en una Hoja2. Sub DividirValorConLimite() 'Por.Dante Amor Application.ScreenUpdating = False Application.DisplayAlerts = False Set h1 =...
1 respuesta

Permitir solo determinado formato en celdas

Solicitando nuevamente te ayuda. Como podría hacer para que en una hoja de Excel llamada Datos, la columna A (Consecutivo) acepte solo números; la columna B (Descripción) acepte solo texto y por ultimo la columna C (Fecha) solo fechas. Ademas si al...
1 respuesta

Abrir excel según ruta y copiar filas según columna

Estoy tratando de realizar una macro para gestión de información.. Lo que necesito es que abra el excel cuya ruta se encuentra en el "label2", se posicione en la cerda "e10" de dicho archivo y comience a recorrer la columna "e" .. Está columna tiene...
1 respuesta

Macro para filtrar y elegir columnas y filtros

Tengo una tabla y quiero agregar al rededor de 10 a 15 opciones para elegir filtrar por columna y criterio. Pareciera que puedo usar filtros avanzados pero uso listas desplegables entonces me sirve mas elegir un valor y un criterio para poder...
1 respuesta

Macro para calcular la edad

Para Elsa Matilde Hace poco consulte como calcular la edad de una persona pero la fórmula que utilice no me da la edad exacta (a veces me da más o menos) Ahora tengo esta fórmula, algo larga pero al parecer funciona, pero no se como convertila en...
1 respuesta