copy pasting multiple columns from multiple workbooks into one master workbook

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
8,906
What do you want to do with the Belarus 3 workbook after column N had been populated? Do you want to save it?
 

Some videos you may like

Excel Facts

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.

mogss_04

Board Regular
Joined
May 9, 2019
Messages
57
Yes i want to save it and then use the same file to create the master file as i mentioned in my previous post.
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
8,906
In the Master file you have these headers: ITEM_CODE ITEM_DESCR Country MFG_DATE EXP_DATE
You want to copy theses columns: "country", "Material Code", "Material", "Batch Creation Date", "Batch Expiry Date" from each Belarus file but as you can see, the headers don't match. It would make it much easier to write the code if the headers matched. Would it be a problem if we changed the headers in the Master file to match the headers in the Belarus files?
 

mogss_04

Board Regular
Joined
May 9, 2019
Messages
57
Yes we can keep the headers of the master file same as the headers which are there in Belarus files. It wouldnt be a issue
 

mogss_04

Board Regular
Joined
May 9, 2019
Messages
57
Hi mumps,

Awaiting your reply on the above. Can we code the above now given the headers would be the same in the master file or are there any other issues in the file which i need to look into before you start coding.Let me know for any other issues.

Thank you.
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
8,906
I have the code to copy the columns finished. I'm working on the dates. I always find working with dates tricky so I'm testing that part of the code. Hopefully, I should have something for you soon.
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
8,906
Here is the macro. Change the headers in the Master to match those in the Belarus files. In the Belarus 3 file you have an option called "Restricted-Use" which will leave blank cells in column N because you didn't mention anything about this option. Also, in the Belarus 3 file, you have blank cells in columns B and C starting in row 1440. This will cause a problem if these cells are left blank. If they need to be blank, then the macro will have to be modified. Please advise. Please check the results in column N to make sure they are what you want.
Code:
Sub copyColumns()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, srcWB As Workbook, srcWS As Worksheet, x As Long, i As Long, LastRow As Long, rDate As Range
    Set desWS = ThisWorkbook.Sheets("Base inv data")
    Const strPath As String = "C:\Users\Priyanka Singh\Desktop\VBA code1\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set srcWB = Workbooks.Open(strPath & strExtension)
        If srcWB.Name = "Belarus 3.xlsx" Then
            Set srcWS = Sheets("base")
            LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            With desWS.Range("C:C,E:E,F:F,J:J,K:K")
                For i = 1 To .Areas.Count
                    x = .Areas(i).Column
                    Set Header = srcWS.Rows(1).Find(.Areas(i).Cells(1), LookIn:=xlValues, lookat:=xlWhole)
                    If Not Header Is Nothing Then
                        srcWS.Range(srcWS.Cells(2, Header.Column), srcWS.Cells(LastRow, Header.Column)).Copy desWS.Cells(desWS.Rows.Count, x).End(xlUp).Offset(1, 0)
                    End If
                Next i
            End With
            With srcWS
                .Range("B1:N" & LastRow).AutoFilter Field:=8, Criteria1:="=Unrestricted Use", Operator:=xlOr, Criteria2:="=Unrestricted-Use Mat"
                For Each rDate In .Range("M2:M" & LastRow).SpecialCells(xlCellTypeVisible)
                    If rDate.Value > DateSerial(Year(Date) + 1, Month(Date), Day(Date)) Then
                        rDate.Offset(0, 1) = "Usable (>12)"
                    ElseIf rDate.Value > DateSerial(Year(Date), Month(Date) + 7, Day(Date)) And rDate.Value < DateSerial(Year(Date) + 1, Month(Date), Day(Date)) Then
                        rDate.Offset(0, 1) = "Usable (7-12)"
                    ElseIf rDate.Value > DateSerial(Year(Date), Month(Date), Day(Date)) And rDate.Value < DateSerial(Year(Date), Month(Date) + 7, Day(Date)) Then
                        rDate.Offset(0, 1) = "Near expiry"
                    ElseIf rDate.Value < Date Then
                        rDate.Offset(0, 1) = "Expired"
                    End If
                Next rDate
                .Range("B1:N" & LastRow).AutoFilter Field:=8, Criteria1:="Blocked Stock", Operator:=xlOr, Criteria2:="Valuated Goods Receipt Blocked Stock"
                .Range("N2:N" & LastRow).SpecialCells(xlCellTypeVisible) = "Blocked"
                .Range("B1:N" & LastRow).AutoFilter Field:=8, Criteria1:="Transit", Operator:=xlOr, Criteria2:="Intransit"
                .Range("N2:N" & LastRow).SpecialCells(xlCellTypeVisible) = "Transit"
                .Range("B1:N" & LastRow).AutoFilter Field:=8, Criteria1:="Quality inspection"
                .Range("N2:N" & LastRow).SpecialCells(xlCellTypeVisible) = "Quality inspection"
                .Range("B1").AutoFilter
                srcWB.Close True
            End With
        Else
            Set srcWS = Sheets("base")
            LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            With desWS.Range("C:C,E:E,F:F,J:J,K:K")
                For i = 1 To .Areas.Count
                    x = .Areas(i).Column
                    Set Header = srcWS.Rows(1).Find(.Areas(i).Cells(1), LookIn:=xlValues, lookat:=xlWhole)
                    If Not Header Is Nothing Then
                        srcWS.Range(srcWS.Cells(2, Header.Column), srcWS.Cells(LastRow, Header.Column)).Copy desWS.Cells(desWS.Rows.Count, x).End(xlUp).Offset(1, 0)
                    End If
                Next i
            End With
            srcWB.Close False
        End If
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub
 

mogss_04

Board Regular
Joined
May 9, 2019
Messages
57
Hi Mumps,


Thank you so much for looking into the above.


1. For option called "Restricted-Use" it is Restricted that should be populated in column N. I added that in the code. It works fine.


2. And yes we can have blank columns. For certain products Item code wouldnt exist and other way round so the blanks need to be there the way it is.


3. And for copying columns the code works in this file. However I had certain questions. Do the columns which exist in the master file have to be present in all source files. If one of the columns which needs to be copied in master files are missing in the source files, will the code work?


Also this was for one of the regions that is Belarus. I tried similar code for other region but it doesnt copy paste one of the columns that is "Salable Stock". Also while you were looking into the coding I had tried coding the copy pasting based on column names on own.The source files may not have all the columns which are to be pasted in master file.But if the columns which exist in master file are found , they should be pasted and if not found left blank for those records the columns which are not found. My code as well as your code doesnt paste the "Salable Stock" column from source files into master file. I dont know what is the issue. Can you look into the code below. I shall upload the files.I have both codes in the master file. Your code in Module 2 and mine in Module 1.I am uploading 4 files for reference although there 8 such files. 3 source files and 1 master file.


C:\Users\Priyanka Singh\Desktop\May - Inventory Automation\MW\


https://www.dropbox.com/s/e0gr1ytmhlh4wes/MW Stock.xlsm?dl=0

https://www.dropbox.com/s/1kwjwlr16pngvh9/File2 - Braz.xlsx?dl=0

https://www.dropbox.com/s/cqdg403jw2kxfqt/File1 - BAL.xlsx?dl=0

https://www.dropbox.com/s/m1tluslskroqhq8/File 3 - Bel.xlsx?dl=0




4. For column N under as i Had mentioned below in post#15


"if the expiry date falls 12 months after the the current month i.e 2020 June onwards then column N should be polpulated as"Usable (>12)", if expiry date falls between 7 - 12 months after expiry date
which is from December 2019 - May 2020 then column N should be polpulated as"Usable (7-12)"


I see that expiry date falling under May 2020 is populated under "Usable(>12)" instead of "Usable (7-12)" . This is for all expiry date falling on "5/31/2020". If you filter the sheet by this expiry date , there are some 15 records . Could you please help fix this.Rest the code works well. Thank you so much once again.
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
8,906
Try this revised macro for the Belarus files.
Code:
Sub copyColumns()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, srcWB As Workbook, srcWS As Worksheet, x As Long, i As Long, LastRow As Long, LastRow2 As Long, rDate As Range
    Set desWS = ThisWorkbook.Sheets("Base inv data")
    'Const strPath As String = "C:\Users\Priyanka Singh\Desktop\VBA code1\"
    Const strPath As String = "C:\Forum Help\mogss\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set srcWB = Workbooks.Open(strPath & strExtension)
        If srcWB.Name = "Belarus 3.xlsx" Then
            Set srcWS = Sheets("base")
            LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            With desWS.Range("C:C,E:E,F:F,J:J,K:K")
                For i = 1 To .Areas.Count
                    LastRow2 = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                    x = .Areas(i).Column
                    Set Header = srcWS.Rows(1).Find(.Areas(i).Cells(1), LookIn:=xlValues, lookat:=xlWhole)
                    If Not Header Is Nothing Then
                        srcWS.Range(srcWS.Cells(2, Header.Column), srcWS.Cells(LastRow, Header.Column)).Copy desWS.Cells(LastRow2, x)
                    End If
                Next i
            End With
            With srcWS
                .Range("B1:N" & LastRow).AutoFilter Field:=8, Criteria1:="=Unrestricted Use", Operator:=xlOr, Criteria2:="=Unrestricted-Use Mat"
                For Each rDate In .Range("M2:M" & LastRow).SpecialCells(xlCellTypeVisible)
                    If rDate.Value > DateSerial(Year(Date) + 1, Month(Date) + 1, 1) Then
                        rDate.Offset(0, 1) = "Usable (>12)"
                    ElseIf rDate.Value > DateSerial(Year(Date), Month(Date) + 7, 1) And rDate.Value < DateSerial(Year(Date) + 1, Month(Date) + 1, 1) Then
                        rDate.Offset(0, 1) = "Usable (7-12)"
                    ElseIf rDate.Value > DateSerial(Year(Date), Month(Date), 1) And rDate.Value < DateSerial(Year(Date), Month(Date) + 7, 1) Then
                        rDate.Offset(0, 1) = "Near expiry"
                    ElseIf rDate.Value < DateSerial(Year(Date), Month(Date), 1) Then
                        rDate.Offset(0, 1) = "Expired"
                    End If
                Next rDate
                .Range("B1:N" & LastRow).AutoFilter Field:=8, Criteria1:="Blocked Stock", Operator:=xlOr, Criteria2:="Valuated Goods Receipt Blocked Stock"
                .Range("N2:N" & LastRow).SpecialCells(xlCellTypeVisible) = "Blocked"
                .Range("B1:N" & LastRow).AutoFilter Field:=8, Criteria1:="Transit", Operator:=xlOr, Criteria2:="Intransit"
                .Range("N2:N" & LastRow).SpecialCells(xlCellTypeVisible) = "Transit"
                .Range("B1:N" & LastRow).AutoFilter Field:=8, Criteria1:="Quality inspection"
                .Range("N2:N" & LastRow).SpecialCells(xlCellTypeVisible) = "Quality inspection"
                .Range("B1:N" & LastRow).AutoFilter Field:=8, Criteria1:="Restricted-Use"
                .Range("N2:N" & LastRow).SpecialCells(xlCellTypeVisible) = "Restricted"
                .Range("B1").AutoFilter
                srcWB.Close True
            End With
        Else
            Set srcWS = Sheets("base")
            LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            With desWS.Range("C:C,E:E,F:F,J:J,K:K")
                For i = 1 To .Areas.Count
                    LastRow2 = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                    x = .Areas(i).Column
                    Set Header = srcWS.Rows(1).Find(.Areas(i).Cells(1), LookIn:=xlValues, lookat:=xlWhole)
                    If Not Header Is Nothing Then
                        srcWS.Range(srcWS.Cells(2, Header.Column), srcWS.Cells(LastRow, Header.Column)).Copy desWS.Cells(LastRow2, x)
                    End If
                Next i
            End With
            srcWB.Close False
        End If
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub
I'll work on the code for the other region tomorrow.
 

Watch MrExcel Video

Forum statistics

Threads
1,095,840
Messages
5,446,817
Members
405,416
Latest member
galoli

This Week's Hot Topics

Top