Excel Level (Immortal)

T

Tofik

Board Regular
Joined
Feb 4, 2021
Messages
114
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
Hi guys. Who can change the VBA code ?
The one user [B]maabadi[/B] helped me some time ago with VBA and writes me the code which can gather and take needed information from different Excels files from the folder and gather all needed info to one Excel file. It was the best program which I am using till nova day.
And now I responsible to one more new job to check some information from my Main Log and this job also have a lot of different Excel files in the folder.
I want again gather all needed information from different Excels into one Excel file for easy checking process. I appreciate If you can recommend to me course or good video lessons about VBA coding because I understood that it's easy way to organizing work with big Databases.

The old VBA code ( I don't know how it can be useful for you ) :
VBA Code: 
Sub ImportFiles3()
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


Excel File :
drive.google.com

10140-CON-PIP-45_W-0120.xlsx

drive.google.com drive.google.com
With yellow color I just show you what places for me important. ( Need info only from this place )
The Excels file which I have can consist from 1 Sheet or can consist from 6 Sheets.

1620224787780.png

The excel file which I have can consist from 1 Sheet or 6 Sheets.

How it should be or how I imagine how it should be, the ( 1st Version ) or ( 2d Version ) I don't know which easier fore you to create it . Its not matter fore me (as it will be convenient for you)
Example 1
1620225772913.png

Example 2
1620225978609.png


A small note about the Sheet if you can still add the Sheet to the left or wherever so that I can more accurately determine its position on the paper where I will enter the information.( In Hard copy with pen ):
Example 1
1620226605445.png

This post turned out to be a bit long and I think it won't scare you.?
I also wanted to thank all those who have read and spent their time to solve this problem, you are experts in your field.?
Thank you.
 

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes
Sort by date Sort by votes
and How to change if i have more sheet ( Shet1 , Sheet 2 , Sheet3 , Sheet 4 , Sheet5 ,Sheet 6 )
VBA Code: 
If xWS.Name = "10140-CON-PIP-12" Then
 
Upvote 0
This macro create for all excel files in one folder.
if you have more than 1 file then if you want we can add also workbook name.
Try this:
VBA Code: 
Sub ImportFiles4()
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
Lr = DestSheet.Range("A" & Rows.Count).End(xlUp).Row
LrS = xWS.Range("A21").End(xlDown).Row
LCS = LrS - 20
LCD = DestSheet.Cells(1, Columns.Count).End(xlToLeft).Column + 1
If Lr = 1 Then
Range(xWS.Cells(14, 1), xWS.Cells(20, 99)).Copy DestSheet.Range("C1")
Range(xWS.Cells(21, 1), xWS.Cells(LrS, 99)).Copy Range(DestSheet.Cells(8, 3), DestSheet.Cells(LrS - 13, 101))
DestSheet.Range("A1").Value = "Sheet Name"
DestSheet.Range("B1").Value = "Report Number"
Range(DestSheet.Cells(8, 1), DestSheet.Cells(LrS - 13, 1)).Value = xWS.Name
Range(DestSheet.Cells(8, 2), DestSheet.Cells(LrS - 13, 2)).Value = xWS.Range("AY9").Value
Else
Range(xWS.Cells(21, 1), xWS.Cells(LrS, 99)).Copy Range(DestSheet.Cells(Lr + 1, 3), DestSheet.Cells(Lr + LCS, 101))
Range(DestSheet.Cells(Lr + 1, 1), DestSheet.Cells(Lr + LCS, 1)).Value = xWS.Name
Range(DestSheet.Cells(Lr + 1, 2), DestSheet.Cells(Lr + LCS, 2)).Value = xWS.Range("AY9").Value
End If
Next xWS
Workbooks(xStrAWBName).Close
FileName = Dir()
Loop
Lr = DestSheet.Range("A" & Rows.Count).End(xlUp).Row
DestSheet.Range("C1:Q7").Copy
DestSheet.Range("A1:A7").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
DestSheet.Range("B1:B7").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
DestSheet.Range("C8:Q8").Copy
DestSheet.Range("A8:A" & Lr).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
DestSheet.Range("B8:B" & Lr).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
DestSheet.Columns("A:CU").AutoFit
DestSheet.Name = "Consolidate"
xTWB.Save
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
 
Upvote 0
Solution
maabadi said:
This macro create for all excel files in one folder.
if you have more than 1 file then if you want we can add also workbook name.
Try this:
VBA Code: 
Sub ImportFiles4()
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
Lr = DestSheet.Range("A" & Rows.Count).End(xlUp).Row
LrS = xWS.Range("A21").End(xlDown).Row
LCS = LrS - 20
LCD = DestSheet.Cells(1, Columns.Count).End(xlToLeft).Column + 1
If Lr = 1 Then
Range(xWS.Cells(14, 1), xWS.Cells(20, 99)).Copy DestSheet.Range("C1")
Range(xWS.Cells(21, 1), xWS.Cells(LrS, 99)).Copy Range(DestSheet.Cells(8, 3), DestSheet.Cells(LrS - 13, 101))
DestSheet.Range("A1").Value = "Sheet Name"
DestSheet.Range("B1").Value = "Report Number"
Range(DestSheet.Cells(8, 1), DestSheet.Cells(LrS - 13, 1)).Value = xWS.Name
Range(DestSheet.Cells(8, 2), DestSheet.Cells(LrS - 13, 2)).Value = xWS.Range("AY9").Value
Else
Range(xWS.Cells(21, 1), xWS.Cells(LrS, 99)).Copy Range(DestSheet.Cells(Lr + 1, 3), DestSheet.Cells(Lr + LCS, 101))
Range(DestSheet.Cells(Lr + 1, 1), DestSheet.Cells(Lr + LCS, 1)).Value = xWS.Name
Range(DestSheet.Cells(Lr + 1, 2), DestSheet.Cells(Lr + LCS, 2)).Value = xWS.Range("AY9").Value
End If
Next xWS
Workbooks(xStrAWBName).Close
FileName = Dir()
Loop
Lr = DestSheet.Range("A" & Rows.Count).End(xlUp).Row
DestSheet.Range("C1:Q7").Copy
DestSheet.Range("A1:A7").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
DestSheet.Range("B1:B7").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
DestSheet.Range("C8:Q8").Copy
DestSheet.Range("A8:A" & Lr).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
DestSheet.Range("B8:B" & Lr).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
DestSheet.Columns("A:CU").AutoFit
DestSheet.Name = "Consolidate"
xTWB.Save
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
Click to expand...
Yes it works very good. Thank you for your time Maabadi and your job . Now I understand that on this forum your excel achievement is Immortal ???
Also this formula show it (if you have more than 1 file then if you want we can add also workbook name.)
1620381189587.png
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question Question
Append data to master file
Replies
6
Views
337
Alex Blakenburg
A
G
  • Solved
Change Macro to import files from hyperlinks
2
Replies
12
Views
938
GarnesGambit
G
S
  • Solved
Transfer data from several workbooks to the main one
Replies
7
Views
654
eiloken
E
H
  • Solved
Splitting Data into Workbooks - EDIT HELP
Replies
1
Views
254
horrellbt01
H
T
  • Question Question
VBA formula to need correcting.
Replies
0
Views
694
Tofik
T

Forum statistics

Threads
1,223,893
Messages
6,175,248
Members
452,623
Latest member
cliftonhandyman

Share this page

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
Back
Top