VBA formula to need correcting.

Tofik

Board Regular
Joined
Feb 4, 2021
Messages
96
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
Hi guys, I have a problem. I want tell you some story how it was happen. Nearly 4 month ago I post topic about VBA code to help me gather all info from the same excel files and one guy from this forum create to me VBA code which compilated all same Excels from the folder into one ( I have a very routine paper job ). Everything was good and I was happy, but after some time construction side had a lot of reports and they can't do their job in time. All reports which they creates for me were typed by themselves(manually). But now because of a lot of job they start to use formula to create those reports automatically and it was affected on my VBA code and I don't know how I can fix it. That's why I appeal to you. If someone can fix the VBA code it will be the best news for me today. Reports all rise from hour to hour.

1) I show you Image from Excel with Errors below.
2) I add the Excel as an Example of Report with which I work all day and only number in cells can be different but the structural they are same. In yellow color I mark important places which I need.


VBA Code:
Code which I used was this:
Sub Visual_Import()
Dim xWS As Worksheet, xTWB As Workbook, DestSheet As Worksheet, Head As Range
Dim xStrAWBName As String, FolderName As String, sItem As String, Header As Long
Dim FolderPath As String, fldr As FileDialog, Lr As Long, LCD As Long, R As Long
Dim os As Long, LrS As Long, LCS As Long, FileName As String
On Error Resume Next
Set xTWB = ThisWorkbook
Set DestSheet = xTWB.ActiveSheet
  Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    FolderName = sItem
    Set fldr = Nothing
    FolderPath = FolderName & "\"
FileName = Dir(FolderPath & "*.xls*")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Do While FileName <> ""
Workbooks.Open FileName:=FolderPath & FileName, ReadOnly:=True
xStrAWBName = ActiveWorkbook.Name
For Each xWS In ActiveWorkbook.Sheets
If xWS.Name = "10140-CON-PIP-12" Then
Lr = DestSheet.Range("A" & Rows.Count).End(xlUp).Row
LrS = Application.WorksheetFunction.Count(xWS.Range("A11:A26"))
LCS = xWS.Cells(1, Columns.Count).End(xlToLeft).Column + 1
LCD = DestSheet.Cells(1, Columns.Count).End(xlToLeft).Column + 1
If Lr = 1 Then
Range(xWS.Cells(9, 1), xWS.Cells(10, 35)).Copy DestSheet.Range("B1")
Range(xWS.Cells(11, 1), xWS.Cells(11 + LrS - 1, 35)).Copy Range(DestSheet.Cells(3, 2), DestSheet.Cells(LrS + 2, 36))
DestSheet.Range("A1").Value = "Report Number"
Range(DestSheet.Cells(3, 1), DestSheet.Cells(LrS + 2, 1)).Value = xWS.Range("D7").Value
DestSheet.Cells(1, 37).Value = "Drawing"
Range(DestSheet.Cells(3, 37), DestSheet.Cells(LrS + 2, 37)).Value = Trim(Right(xWS.Range("V4").Value, Len(xWS.Range("V4").Value) - Application.WorksheetFunction.Find("/", xWS.Range("V4").Value)))
Range(xWS.Cells(9, 1), xWS.Cells(10, 35)).Copy
Range(DestSheet.Cells(1, 2), DestSheet.Cells(2, 37)).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range(xWS.Cells(11, 1), xWS.Cells(11 + LrS - 1, 1)).Copy
Range(DestSheet.Cells(3, 1), DestSheet.Cells(LrS + 2, 1)).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range(xWS.Cells(11, 1), xWS.Cells(11 + LrS - 1, 35)).Copy
Range(DestSheet.Cells(3, 2), DestSheet.Cells(LrS + 2, 37)).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range(DestSheet.Cells(1, 2), DestSheet.Cells(2, 2)).Copy
Range(DestSheet.Cells(1, 1), DestSheet.Cells(2, 1)).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Else
Range(xWS.Cells(11, 1), xWS.Cells(11 + LrS - 1, 35)).Copy Range(DestSheet.Cells(Lr + 1, 2), DestSheet.Cells(Lr + LrS, 36))
Range(DestSheet.Cells(Lr + 1, 1), DestSheet.Cells(Lr + LrS, 1)).Value = xWS.Range("D7").Value
Range(DestSheet.Cells(Lr + 1, 37), DestSheet.Cells(Lr + LrS, 37)).Value = Trim(Right(xWS.Range("V4").Value, Len(xWS.Range("V4").Value) - Application.WorksheetFunction.Find("/", xWS.Range("V4").Value)))
Range(xWS.Cells(11, 1), xWS.Cells(11 + LrS - 1, 35)).Copy
Range(DestSheet.Cells(Lr + 1, 2), DestSheet.Cells(Lr + LrS, 37)).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range(xWS.Cells(11, 1), xWS.Cells(11 + LrS - 1, 1)).Copy
Range(DestSheet.Cells(Lr + 1, 1), DestSheet.Cells(Lr + LrS, 1)).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
End If
Next xWS
Workbooks(xStrAWBName).Close
FileName = Dir()
Loop
DestSheet.Columns("A:AK").WrapText = False
DestSheet.Columns("A:AK").AutoFit
DestSheet.Name = "Consolidate"
xTWB.Save
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub

1) This is the missing info which I have today:
Note( How we can correct the VBA code to take only that info which I saw in Excel Report version and it shouldn't matter was it type manually or use formula.
1628150092974.png


2)The Example of the Visual Report :


Thank you guys. It is very important for me and I appreciate your help.
 

Excel Facts

What is the shortcut key for Format Selection?
Ctrl+1 (the number one) will open the Format dialog for whatever is selected.

Forum statistics

Threads
1,148,275
Messages
5,745,803
Members
423,976
Latest member
vladm1010

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top