copy pasting multiple columns from multiple workbooks into one master workbook

[mogss_04]

Hi can you let me know how to code the below,

I have 3 files named Belarus, Belarus2 and Belarus3 and i need to paste the the below from each of the files into master file.Would it be possible to execute all at once. I have all the files saved in the folder in the path "C:\Users\Priyanka Singh\Desktop\VBA code"

Belarus file to master file
1. "Country" column from Belarus to "Country" in masterfile
2. "Material " column from Belarus to "ITEM_CODE" in master file
3. "Material Name" column from Belarus to "ITEM_DESCR" in master file
4. "Batch" column from Belarus to "LOT_NO" in master file
5. "Manufacturing Date" column from Belarus to "MFG_DATE"
6. "Batch Expiry Date" column from Belarus to "EXP_DATE" in master file
7. "Total Qty column" from Belarus to "QUANTITY" in master file

Belarus2 file to master file
1. "Country" column from Belarus2 to "Country" in masterfile
2. "HANA Code" column from Belarus2 to "ITEM_CODE" in masterfile
3. "Product Name" column from Belarus2 to "ITEM_DESCR" in masterfile
4. "Total Stock Qty" column from Belarus2 to "QUANTITY" in masterfile

Belarus3 file to master file
1. "Country" column from Belarus3 to "Country" in masterfile
2. "Material Code " column from Belarus3 to "ITEM_CODE" in master file
3. "Material " column from Belarus3 to "ITEM_DESCR" in master file
4. "Usage " column from Belarus3 to "Inventory Flag" in master file
5. "Batch Creation Date" column from Belarus3 to "MFG_DATE"
6. "Batch Expiry Date" column from Belarus3 to "EXP_DATE" in master file
7. "Qty Sales Unit (derived from base unit & product description)" column from Belarus3 to "QUANTITY" in master file

Thank you.

 

[mumps]

What do you want to do with the Belarus 3 workbook after column N had been populated? Do you want to save it?

 

[mogss_04]

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]

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]

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]

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]

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]

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.

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]

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]

Try this revised macro for the Belarus files.

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.

 

[mogss_04]

Sure. Will do.

The above code works fine. Thank you so much