Ghuphuneho
02-05-2020, 12:30 PM
Hi,
i have a problem and i dont know how resolve it
i need to transfer a info from several excel files to one. My VBA code works but it changes some number values. for example, if a cell values is 89,000 the code transforme the value to 89.000. but not all, just some
Please i need your help.
i have 4 sheets, and each one has an associated macro. Then with a button I call them one by one
The 4 codes are more or less the same, I leave one as a reference. I leave attached the files.
Thak you very much!!!!:crying::crying:
Sub MB25D()
Application.ScreenUpdating = False
Dim i As Integer
Worksheets.Add.Name = "MB25D"
Call ContarArchivosZI
Application.ScreenUpdating = False
Dim WorkBookOrigen As Workbook
Dim wsOrigen As Excel.Worksheet, _
wsDestino As Excel.Worksheet, _
rngOrigen As Excel.Range, _
rngDestino As Excel.Range, _
NombreArchivo As String, _
carpeta As String
Dim CNT As Integer
carpeta = ActiveWorkbook.Path & "\"
nArchivo = 1
NombreArchivo = Dir(carpeta & "MB25" & "*.MH*")
Do While Len(NombreArchivo) > 0
Set WorkBookOrigen = Workbooks.Open(carpeta & NombreArchivo)
NombreArchivo = Dir()
ThisWorkbook.Activate
Set wsOrigen = WorkBookOrigen.Worksheets(1)
Set wsDestino = Worksheets("MB25D")
Const celdaOrigen = "A1"
Set rngOrigen = wsOrigen.Range(celdaOrigen)
wsOrigen.Activate
rngOrigen.Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Errores:
If Err.Number = 1004 Then
wsOrigen.Activate
rngOrigen.Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
End If
For n = 1 To 1
wsDestino.Activate
'On Error GoTo Errores
Sheets("MB25D").Select
wsDestino.Cells(Columns.Count, 2).End(xlUp).Offset(0, -1).PasteSpecial
Next n
Application.CutCopyMode = False
WorkBookOrigen.Save
nArchivo = nArchivo + 1
Call Progreso
Loop
j = nArchivo - 1
Sheets("MB25").Select
i = Cells(Rows.Count, 1).End(xlUp).Row
Sheets("MB25").Range("A1:H" & i + 1).Clear
Range("A1").Select
ActiveCell.FormulaR1C1 = "=+MB25D!RC"
Range("A1").Select
Selection.AutoFill Destination:=Range("A1:H1"), Type:=xlFillDefault
Range("A1:AJ1").Select
Range("AJ1").Select
Sheets("MB25D").Select
i = Cells(Rows.Count, 1).End(xlUp).Row
Sheets("MB25").Select
Range("A1:H1").Select
Selection.AutoFill Destination:=Range("A1:H" & i)
Range("I2:X2").Select
Selection.AutoFill Destination:=Range("I2:X" & i)
Sheets("MB25").Select
i = Cells(Rows.Count, 1).End(xlUp).Row
Range("A1:H" & i).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Range("A2322").Select
Selection.End(xlUp).Select
ActiveWindow.SmallScroll Down:=0
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.DisplayAlerts = False
Sheets("MB25D").Delete
Application.DisplayAlerts = True
Dim celda As Range
Application.StatusBar = "Convirtiendo celdas seleccionadas a formato de número..."
i = Cells(Rows.Count, 1).End(xlUp).Row
Range("H2:H" & i).Select
Selection.NumberFormat = "m/d/yyyy"
Range("B2:E" & i).Select
Selection.NumberFormat = "0"
Range("B2:E" & i).Select
Selection.NumberFormat = "0"
Range("G2:G" & i).Select
Selection.NumberFormat = "0"
Sheets("MB25").Select
Dim r As Integer
Dim f As Integer
f = 2
r = 2
i = Cells(Rows.Count, 1).End(xlUp).Row
Do While r < i
Range("B" & r).Select
Range("B" & f).Select
If Range("B" & r) = "" Then
Range("B" & r).Value = 0
Else
Range("B" & r) = Range("B" & r).Value * 1
Range("B" & r).Interior.Color = RGB(150, 160, 26)
End If
r = r + 1
Loop
Dim palabra, extension
extension = 1
f = 2
r = 2
i = Cells(Rows.Count, 1).End(xlUp).Row
Do While r < i
palabra = Range("E" & r)
Range("y" & r) = Left(palabra, extension)
Range("E" & r).Select
Range("E" & f).Select
If Range("Y" & r) = "S" Then
Else
Range("E" & r) = Range("E" & r).Value * 1
Range("E" & r).Interior.Color = RGB(150, 160, 26)
End If
r = r + 1
Loop
Range("B2:E" & i).Select
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
Public Sub Progreso()
Dim contador As Integer
Dim Maximo As Integer
Dim Mitiempo As Double
Maximo = nArchivo - 1
For contador = 1 To Maximo Step 1
Mitiempo = Timer
Do
Loop While Timer - Mitiempo < 0.02
Application.StatusBar = "Progreso: " & Maximo & _
" de " & i & " (" & Format(Maximo / i, "Percent") & ")"
DoEvents
Next contador
Application.StatusBar = False
End Sub
Public Sub ContarArchivosMB25()
Dim cNombreArchivo, cCarpeta As String
cCarpeta = ActiveWorkbook.Path & "\"
Conteo = 1
25926
cNombreArchivo = Dir(cCarpeta & "MB25" & "*.MH*")
Do While Len(cNombreArchivo) > 0
cNombreArchivo = Dir()
Conteo = Conteo + 1
Loop
i = Conteo - 1
End Sub
i have a problem and i dont know how resolve it
i need to transfer a info from several excel files to one. My VBA code works but it changes some number values. for example, if a cell values is 89,000 the code transforme the value to 89.000. but not all, just some
Please i need your help.
i have 4 sheets, and each one has an associated macro. Then with a button I call them one by one
The 4 codes are more or less the same, I leave one as a reference. I leave attached the files.
Thak you very much!!!!:crying::crying:
Sub MB25D()
Application.ScreenUpdating = False
Dim i As Integer
Worksheets.Add.Name = "MB25D"
Call ContarArchivosZI
Application.ScreenUpdating = False
Dim WorkBookOrigen As Workbook
Dim wsOrigen As Excel.Worksheet, _
wsDestino As Excel.Worksheet, _
rngOrigen As Excel.Range, _
rngDestino As Excel.Range, _
NombreArchivo As String, _
carpeta As String
Dim CNT As Integer
carpeta = ActiveWorkbook.Path & "\"
nArchivo = 1
NombreArchivo = Dir(carpeta & "MB25" & "*.MH*")
Do While Len(NombreArchivo) > 0
Set WorkBookOrigen = Workbooks.Open(carpeta & NombreArchivo)
NombreArchivo = Dir()
ThisWorkbook.Activate
Set wsOrigen = WorkBookOrigen.Worksheets(1)
Set wsDestino = Worksheets("MB25D")
Const celdaOrigen = "A1"
Set rngOrigen = wsOrigen.Range(celdaOrigen)
wsOrigen.Activate
rngOrigen.Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Errores:
If Err.Number = 1004 Then
wsOrigen.Activate
rngOrigen.Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
End If
For n = 1 To 1
wsDestino.Activate
'On Error GoTo Errores
Sheets("MB25D").Select
wsDestino.Cells(Columns.Count, 2).End(xlUp).Offset(0, -1).PasteSpecial
Next n
Application.CutCopyMode = False
WorkBookOrigen.Save
nArchivo = nArchivo + 1
Call Progreso
Loop
j = nArchivo - 1
Sheets("MB25").Select
i = Cells(Rows.Count, 1).End(xlUp).Row
Sheets("MB25").Range("A1:H" & i + 1).Clear
Range("A1").Select
ActiveCell.FormulaR1C1 = "=+MB25D!RC"
Range("A1").Select
Selection.AutoFill Destination:=Range("A1:H1"), Type:=xlFillDefault
Range("A1:AJ1").Select
Range("AJ1").Select
Sheets("MB25D").Select
i = Cells(Rows.Count, 1).End(xlUp).Row
Sheets("MB25").Select
Range("A1:H1").Select
Selection.AutoFill Destination:=Range("A1:H" & i)
Range("I2:X2").Select
Selection.AutoFill Destination:=Range("I2:X" & i)
Sheets("MB25").Select
i = Cells(Rows.Count, 1).End(xlUp).Row
Range("A1:H" & i).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Range("A2322").Select
Selection.End(xlUp).Select
ActiveWindow.SmallScroll Down:=0
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.DisplayAlerts = False
Sheets("MB25D").Delete
Application.DisplayAlerts = True
Dim celda As Range
Application.StatusBar = "Convirtiendo celdas seleccionadas a formato de número..."
i = Cells(Rows.Count, 1).End(xlUp).Row
Range("H2:H" & i).Select
Selection.NumberFormat = "m/d/yyyy"
Range("B2:E" & i).Select
Selection.NumberFormat = "0"
Range("B2:E" & i).Select
Selection.NumberFormat = "0"
Range("G2:G" & i).Select
Selection.NumberFormat = "0"
Sheets("MB25").Select
Dim r As Integer
Dim f As Integer
f = 2
r = 2
i = Cells(Rows.Count, 1).End(xlUp).Row
Do While r < i
Range("B" & r).Select
Range("B" & f).Select
If Range("B" & r) = "" Then
Range("B" & r).Value = 0
Else
Range("B" & r) = Range("B" & r).Value * 1
Range("B" & r).Interior.Color = RGB(150, 160, 26)
End If
r = r + 1
Loop
Dim palabra, extension
extension = 1
f = 2
r = 2
i = Cells(Rows.Count, 1).End(xlUp).Row
Do While r < i
palabra = Range("E" & r)
Range("y" & r) = Left(palabra, extension)
Range("E" & r).Select
Range("E" & f).Select
If Range("Y" & r) = "S" Then
Else
Range("E" & r) = Range("E" & r).Value * 1
Range("E" & r).Interior.Color = RGB(150, 160, 26)
End If
r = r + 1
Loop
Range("B2:E" & i).Select
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
Public Sub Progreso()
Dim contador As Integer
Dim Maximo As Integer
Dim Mitiempo As Double
Maximo = nArchivo - 1
For contador = 1 To Maximo Step 1
Mitiempo = Timer
Do
Loop While Timer - Mitiempo < 0.02
Application.StatusBar = "Progreso: " & Maximo & _
" de " & i & " (" & Format(Maximo / i, "Percent") & ")"
DoEvents
Next contador
Application.StatusBar = False
End Sub
Public Sub ContarArchivosMB25()
Dim cNombreArchivo, cCarpeta As String
cCarpeta = ActiveWorkbook.Path & "\"
Conteo = 1
25926
cNombreArchivo = Dir(cCarpeta & "MB25" & "*.MH*")
Do While Len(cNombreArchivo) > 0
cNombreArchivo = Dir()
Conteo = Conteo + 1
Loop
i = Conteo - 1
End Sub