Posts by falak

Can you briefly describe how i can do power query?

Hi,

Im trying to write an excel VBA code:
Master file is where the file should be uploaded
Master file has row 3 filled with the headers or Column names (examples; destination, round trip distance, so on.....)
the file should be uploaded to this master file by browsing through the computer
the uploading file's row 1 has same headers as row 3 of the master file (should be checked by code)...(examples; destination, round trip distance, so on.....)
if its correct then all the values from each column of the uploading file should be filled in the same name column of the master file this code is for n number of rows

Here is my code, what i am doing wrong
attaching both of my files for your reference

Sub upload_data()
    Dim WScopy As Worksheet, WSdest As Worksheet, desWB As Workbook, FileToOpen As Variant, cRow As Long, Lastrow As Long
    Dim i As Long, v1 As Variant, fVisRow As Long, lVisRow As Long
    Set desWB = ThisWorkbook
    Set WSdest = desWB.Sheets(1)
    Application.ScreenUpdating = False
    FileToOpen = Application.GetOpenFilename(Title:="Browse for your file & Import Range", FileFilter:="Excel Files (*.xls*),*xls*")
    If FileToOpen = False Then Exit Sub
    Set OpenBook = Application.Workbooks.Open(FileToOpen)
    
    'Check if column headers match
    Dim headerDict As Object
    Set headerDict = CreateObject("Scripting.Dictionary")
    Dim j As Long
    For j = 1 To WSdest.Cells(3, Columns.Count).End(xlToLeft).Column
        headerDict.Add Trim(WSdest.Cells(3, j).Value), j
    Next j
    For j = 1 To OpenBook.Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
        If Not headerDict.exists(Trim(OpenBook.Sheets(1).Cells(1, j).Value)) Then
            MsgBox "Column headers do not match"
            OpenBook.Close SaveChanges:=False
            Exit Sub
        End If
    Next j
    
    Lastrow = WSdest.Cells(Rows.Count, "A").End(xlUp).Row + 1
    For cRow = 2 To OpenBook.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
        For i = 1 To headerDict.Count
            v1 = OpenBook.Sheets(1).Cells(cRow, headerDict.Items()(i)).Value
            WSdest.Cells(Lastrow, headerDict.Items()(i)).Value = v1
        Next i
        Lastrow = Lastrow + 1
    Next cRow
    OpenBook.Close SaveChanges:=False
    Set headerDict = Nothing
End Sub

Quote from Mumps

My pleasure.

Mumps

Hi. I wish you well. Kindly look into the little problem im facing on the following thread.

Matching Specific Rows and Copy to specific colums. URGENT!

Thankyou

Hi.

Im stuck with a very minor error with the following code.

What i basically want is every OrderNumber in file i.e "Masterfile" ColumnG should get matched with cell of each value in Column Cof file "POD" and for that respective value its Exclusion value in ColumnE (POD filde) should be copied to ColumnL of "Masterfile".

Example: for OrderNumber "9207116072" in A5 of Masterfile should be macthed with the ordernumber in POD irrespective in which row its found in POD file, after its matched and its found to be in C9 of ColumnC (POD) so its respective exclusion value 2 should be paste in L5 of Masterfile

The code as the moment is pasting the POD date ColumnD of POD instead of ColumnE of POD i have attached both the files for reference.

To use exclusion click Upload Exclusions

Sub uploadPODdataexclusions()
 Dim WScopy As Worksheet, WSdest As Worksheet, desWB As Workbook, FileToOpen As Variant, RngList As Object, key As Variant
 Dim DRow As Long, cRow As Long, lastRow As Long, fnd As Range, PO As Range, sAddr As String, arr As Variant, i As Long, j As Long
 
 Set desWB = ThisWorkbook
 Set WSdest = desWB.Sheets(1)
 lastRow = WSdest.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
 Application.ScreenUpdating = False
 FileToOpen = Application.GetOpenFilename(Title:="Browse for your file & Import Range", FileFilter:="Excel Files (*.xls*),*xls*")
 If FileToOpen = False Then Exit Sub
 Set OpenBook = Application.Workbooks.Open(FileToOpen)
 With Sheets(1)
 DRow = .Cells(.Rows.Count, "C").End(xlUp).row
 arr = .Range("C5:C" & DRow).Resize(, 2).Value
 Set RngList = CreateObject("Scripting.Dictionary")
  For i = LBound(arr) To UBound(arr)
 If Not RngList.Exists(arr(i, 1)) Then
 RngList.Add key:=arr(i, 1), Item:=arr(i, 2)
 With WSdest.Cells(5, 1).CurrentRegion
 .AutoFilter 7, arr(i, 1)
 End With
 With WSdest
 .Range("L5:L" & lastRow).SpecialCells(xlCellTypeVisible) = RngList(arr(i, 1))
 End With
 End If
Next i
 WSdest.Range("A5").AutoFilter
 End With
 
 Application.ScreenUpdating = True
  ActiveWorkbook.Close False
 Application.CutCopyMode = False

End Sub

Worked! thankyou for all the help

Quote from Mumps

The attached file shows the results I get when I run the

Well, actually you prolly running the file where data has been already uploaded if you refresh the file its not working ,i have attached the same file below but i clear the quantity already filled in the table to check if the code is working and have the same error

Quote from Mumps

The attached file shows the results I get when I run the macro.

i have attached the same file below but i clear the quantity already filled in the table to check if the code is working and have the same error

Yes i am using on the same file in the post#4 and still have this error, its just im clearing the already filled data in that file to check wether the code is working

Error for your reference

Quote from Mumps

Try:

Code

Sub Matchdata()
    Application.ScreenUpdating = False
    Dim rng As Range, rng2 As Range, RngList As Object, ws As Worksheet, srcWS As Worksheet, fnd As Range, key As Variant
    Dim strdate As String, LastRow As Long, fDate As Range
    Set srcWS = Sheets("Data")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set RngList = CreateObject("Scripting.Dictionary")
    For Each rng In srcWS.Range("F2:F" & LastRow)
        If Not RngList.Exists(rng.Value) Then
            RngList.Add rng.Value, Nothing
        End If
        For Each key In RngList
            With srcWS.Cells(1).CurrentRegion
                .AutoFilter 6, key
                For Each ws In Sheets
                    If ws.Range("BI2") = key Then
                        With srcWS
                            For Each rng2 In .Range("F2:F" & LastRow).SpecialCells(xlCellTypeVisible)
                                Set fnd = ws.Range("BI:BI").Find(rng2.Offset(, 11), LookIn:=xlValues, lookat:=xlWhole)
                                If Not fnd Is Nothing Then
                                    strdate = rng2.Offset(, -2)
                                    Set fDate = ws.Range("BI3").Resize(, ActiveSheet.Cells(3, Columns.Count).End(xlToLeft).Column - 60).Find(CDate(strdate), LookIn:=xlFormulas, lookat:=xlWhole)
                                    ws.Cells(fnd.Row, fDate.Column) = rng2.Offset(, 13)
                                End If
                            Next rng2
                        End With
                    End If
                Next ws
            End With
        Next key
    Next rng
    srcWS.Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub

Display More

there is an error in this line

Set fDate = ws.Range("BI3").Resize(, ActiveSheet.Cells(3, Columns.Count).End(xlToLeft).Column - 60).Find(CDate(strdate), LookIn:=xlFormulas, lookat:=xlWhole)

Quote from Mumps

Try:

Code

Sub Matchdata()
    Application.ScreenUpdating = False
    Dim rng As Range, rng2 As Range, RngList As Object, ws As Worksheet, srcWS As Worksheet, fnd As Range, key As Variant
    Dim strdate As String, LastRow As Long, fDate As Range
    Set srcWS = Sheets("Data")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set RngList = CreateObject("Scripting.Dictionary")
    For Each rng In srcWS.Range("F2:F" & LastRow)
        If Not RngList.Exists(rng.Value) Then
            RngList.Add rng.Value, Nothing
        End If
        For Each key In RngList
            With srcWS.Cells(1).CurrentRegion
                .AutoFilter 6, key
                For Each ws In Sheets
                    If ws.Range("BI2") = key Then
                        With srcWS
                            For Each rng2 In .Range("F2:F" & LastRow).SpecialCells(xlCellTypeVisible)
                                Set fnd = ws.Range("BI:BI").Find(rng2.Offset(, 11), LookIn:=xlValues, lookat:=xlWhole)
                                If Not fnd Is Nothing Then
                                    strdate = rng2.Offset(, -2)
                                    Set fDate = ws.Rows(3).Find(CDate(strdate), LookIn:=xlFormulas, lookat:=xlWhole)
                                    ws.Cells(fnd.Row, fDate.Column) = rng2.Offset(, 13)
                                End If
                            Next rng2
                        End With
                    End If
                Next ws
            End With
        Next key
    Next rng
    srcWS.Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub

Display More

Apologies for this inconvenience, really sorry but can you look at my post#4. this code is perfectly fine but data is pasted in the both the tables as i want it to get pated in the table starting from ColumBI its getting overlapped because of the file having two tables with same dates in column

Quote from Mumps

Try:

Code

Sub Matchdata()
    Application.ScreenUpdating = False
    Dim rng As Range, rng2 As Range, RngList As Object, ws As Worksheet, srcWS As Worksheet, fnd As Range, key As Variant
    Dim strdate As String, LastRow As Long, fDate As Range
    Set srcWS = Sheets("Data")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set RngList = CreateObject("Scripting.Dictionary")
    For Each rng In srcWS.Range("F2:F" & LastRow)
        If Not RngList.Exists(rng.Value) Then
            RngList.Add rng.Value, Nothing
        End If
        For Each key In RngList
            With srcWS.Cells(1).CurrentRegion
                .AutoFilter 6, key
                For Each ws In Sheets
                    If ws.Range("A2") = key Then
                        With srcWS
                            For Each rng2 In .Range("F2:F" & LastRow).SpecialCells(xlCellTypeVisible)
                                Set fnd = ws.Range("A:A").Find(rng2.Offset(, 11), LookIn:=xlValues, lookat:=xlWhole)
                                If Not fnd Is Nothing Then
                                    strdate = rng2.Offset(, -2)
                                    Set fDate = ws.Rows(3).Find(CDate(strdate), LookIn:=xlFormulas, lookat:=xlWhole)
                                    ws.Cells(fnd.Row, fDate.Column) = rng2.Offset(, 13)
                                End If
                            Next rng2
                        End With
                    End If
                Next ws
            End With
        Next key
    Next rng
    srcWS.Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub

Display More

Mumps More clear version of the doc i have t2o (2) tables having same date columns i want this code to run for the table starting from ColumnBI. doc attached

Quote from Mumps

Try:

Code

Sub Matchdata()
    Application.ScreenUpdating = False
    Dim rng As Range, rng2 As Range, RngList As Object, ws As Worksheet, srcWS As Worksheet, fnd As Range, key As Variant
    Dim strdate As String, LastRow As Long, fDate As Range
    Set srcWS = Sheets("Data")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set RngList = CreateObject("Scripting.Dictionary")
    For Each rng In srcWS.Range("F2:F" & LastRow)
        If Not RngList.Exists(rng.Value) Then
            RngList.Add rng.Value, Nothing
        End If
        For Each key In RngList
            With srcWS.Cells(1).CurrentRegion
                .AutoFilter 6, key
                For Each ws In Sheets
                    If ws.Range("A2") = key Then
                        With srcWS
                            For Each rng2 In .Range("F2:F" & LastRow).SpecialCells(xlCellTypeVisible)
                                Set fnd = ws.Range("A:A").Find(rng2.Offset(, 11), LookIn:=xlValues, lookat:=xlWhole)
                                If Not fnd Is Nothing Then
                                    strdate = rng2.Offset(, -2)
                                    Set fDate = ws.Rows(3).Find(CDate(strdate), LookIn:=xlFormulas, lookat:=xlWhole)
                                    ws.Cells(fnd.Row, fDate.Column) = rng2.Offset(, 13)
                                End If
                            Next rng2
                        End With
                    End If
                Next ws
            End With
        Next key
    Next rng
    srcWS.Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub

Display More

@Mumps

As this program is a part of a bigger project, this code isnt working in that document i have updated the document according to the masterfile doc, kindly see that the rows are starting from columBI as it was starting before from ColumnA. Kindly help me edit the above code.

THANKYOU SOOO MUCH FOR ALL THE HELP

Quote from Mumps

My pleasure.

@Mumps I would be really grateful if you could help me on this thread. Link attached hereby

https://www.ozgrid.com/forum/index.php?thread/1226956-vba-code-to-match-certain-rows-and-paste-the-respective-data/

Hi, I'm stuck with few tasks on the project im working on. I would be really grateful if anyone can help me with this,

So Basically my source data will be in worksheet named “Data”.

• In Data, we have to match the number in ColumnF in each row to cell A2 in each worksheet other than Data. Once the number is matched, further operations will be conducted on that matched sheet
• Now, for each row in sheet Data, in its respective matched sheet, we will match the “SKU Number” in the corresponding cell of ColumnQ of Data with each row of ColumnA of the matched sheet.
• For matched SKU Number in the matched Sheet, we will match the date in ColumnD of Data with the respective date column in the matched sheet
• Last, we will paste the “Itm Qty” from ColumnS in Data in the matched date column of the matched sheet

An example of how the program will work, as sheet ‘Data’ in F2 has Sold-to number as ‘123’, from all the spreadsheet cell A2 we matched the respective number ‘123’ which is found to be in sheet named as ‘COSCO’. Now, we will match the cell Q2 value ‘4567’ to column A of ‘COSCO’. When it is matched, in that row we will match cell D2 ‘2-Feb’ with the date columns in ‘COSCO’. When dates are matched, we will copy cell S2 value ‘9’ in the matched date cell. I have uploaded the file for your reference.

Quote from Mumps

Try:

Code

Sub uploadPODdata()
    Dim WScopy As Worksheet, WSdest As Worksheet, desWB As Workbook, FileToOpen As Variant, RngList As Object, key As Variant
    Dim DRow As Long, cRow As Long, Lastrow As Long, fnd As Range, PO As Range, sAddr As String, arr As Variant, i As Long
    Set desWB = ThisWorkbook
    Set WSdest = desWB.Sheets(1)
    Lastrow = WSdest.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Application.ScreenUpdating = False
    FileToOpen = Application.GetOpenFilename(Title:="Browse for your file & Import Range", FileFilter:="Excel Files (*.xls*),*xls*")
    If FileToOpen = False Then Exit Sub
    Set OpenBook = Application.Workbooks.Open(FileToOpen)
    With Sheets(1)
       DRow = .Cells(.Rows.Count, "C").End(xlUp).Row
       arr = .Range("C5:C" & DRow).Resize(, 3).Value
       Set RngList = CreateObject("Scripting.Dictionary")
       For i = LBound(arr) To UBound(arr)
           If Not RngList.Exists(arr(i, 1)) Then
               RngList.Add key:=arr(i, 1), Item:=arr(i, 2) & "|" & arr(i, 3)
               With WSdest.Cells(4, 1).CurrentRegion
                  .AutoFilter 7, arr(i, 1)
               End With
               With WSdest
                   .Range("F5:F" & Lastrow).SpecialCells(xlCellTypeVisible) = Split(RngList(arr(i, 1)), "|")(0)
                   .Range("L5:L" & Lastrow).SpecialCells(xlCellTypeVisible) = Split(RngList(arr(i, 1)), "|")(1)
               End With
           End If
       Next i
       WSdest.Range("A5").AutoFilter
    End With
    With WSdest
        cRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        .Range("N5:N" & cRow).Formula = "=if(F5<=E5,M5*1,M5*0)"
    End With
    Application.ScreenUpdating = True
    ActiveWorkbook.Close False
    Application.CutCopyMode = False
End Sub

Display More

Worked once, the file is getting hanged for some reasons so not sure. Thanks for all the help!

Quote from Mumps

Glad it all worked out and thank you.

corrected POD file for ur reference.

Quote from Mumps

Glad it all worked out and thank you.

Kindly, look into this small problem aswell. thankyou and i wish you well

@Mumps

Copying of an addition of column is required

Hope you are doing well. a very small addition is required in this code as mentioned below right now it was matching the Ordernumber in ColumnC in "POD "file with ColumG in "masterfile" and pasting the respective POD in Column F of "Mastefile", I now want it to copy the data in ColumnE titled as "Exceptions" and paste it into ColumnL of masterfile keeping the format same like for matched order number its respective exceptions should be pasted in ColumnL of masterfile from ColumnE in file "POD"

Code of module POD is atatched for your reference and files are uploaded

Thankyou for all the help

Sub uploadPODdata()
 Dim WScopy As Worksheet, WSdest As Worksheet, desWB As Workbook, FileToOpen As Variant, RngList As Object, key As Variant
 Dim DRow As Long, cRow As Long, Lastrow As Long, fnd As Range, PO As Range, sAddr As String, arr As Variant, i As Long
 Set desWB = ThisWorkbook
 Set WSdest = desWB.Sheets(1)
 Lastrow = WSdest.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
 Application.ScreenUpdating = False
 FileToOpen = Application.GetOpenFilename(Title:="Browse for your file & Import Range", FileFilter:="Excel Files (*.xls*),*xls*")
 If FileToOpen = False Then Exit Sub
 Set OpenBook = Application.Workbooks.Open(FileToOpen)
 With Sheets(1)
 DRow = .Cells(.Rows.Count, "C").End(xlUp).Row
 arr = .Range("C5:C" & DRow).Resize(, 2).Value
 Set RngList = CreateObject("Scripting.Dictionary")
 For i = LBound(arr) To UBound(arr)
 If Not RngList.Exists(arr(i, 1)) Then
 RngList.Add key:=arr(i, 1), Item:=arr(i, 2)
 With WSdest.Cells(4, 1).CurrentRegion
 .AutoFilter 7, arr(i, 1)
 End With
 With WSdest
 .Range("F5:F" & Lastrow).SpecialCells(xlCellTypeVisible) = RngList(arr(i, 1))
 End With
 End If
 Next i
 WSdest.Range("A5").AutoFilter
 End With
 With WSdest
 cRow = .Cells(.Rows.Count, "A").End(xlUp).Row
 .Range("N5:N" & cRow).Formula = "=if(F5<=E5,M5*1,M5*0)"
 End With
 Application.ScreenUpdating = True
  ActiveWorkbook.Close False
 Application.CutCopyMode = False

End Sub