Transfer data based on a criteria

[Thomas Kuriakose]

Dear All

Please find attached an incomplete code for transfer data to one sheet from multiple sheets based on a lookup reference. If the selected commission number is found it should copy the data from column C to K for the specific commission number to the summary sheet. It should also copy the corresponding value from B1 to B3 to he respective summary sheet cell.

Sub transfer()
Dim ws As Worksheet, myCounter
Dim erow, myValue As Long

For Each ws In Sheets

If ws.Range("B1").Value = "S001" Then

myCounter = 1
ws.Select
ws.Range("B6").Select

myValue = ws.Range("B6").Value

Worksheets("Lookup Table").Select

erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

ActiveSheet.Cells(erow, 1) = myValue

nextValue = MsgBox("Value found in " & ws.Name & Chr(10) & _
"Continue?", vbInformation + vbYesNo, _
ws.Name & " B1 = " & ws.Range("B1").Value)

Select Case nextValue
Case Is = vbYes
Case Is = vbNo
Exit Sub
End Select
End If
Next ws


If myCounter = 0 Then
MsgBox "None of the sheets contains a " & Chr(10) & _
"Mentioned Commission Number in cell C6 ", vbInformation, "Not Found"
End If

End Sub

Kindly help to correct the errors and in the result.

thanks,

with regards,
thomas

 

[Thomas Kuriakose]

Dear All,

I found a code on the net to copy data from multiple sheets to summry sheet based on criteria. I tried to edit and run, but again failed. Kindly check this and let me know where the mistakes are -

Sub transfer()
Dim x As String
Dim y As Long, z As Long, a As Long, b As Long, d As Long
x = InputBox("Enter Commission Number")
y = InputBox("Enter column number") 'enter number like 16, 22 etc
d = 2
    For a = 1 To Sheets.Count
        If Worksheets(a).Name <> "Lookup Table" Then
        Worksheets("Lookup Table").Cells(d, 1) = Worksheets(a).Name
        z = Worksheets(a).Cells(Rows.Count, 1).End(xlUp).Row
            For b = 2 To z
                If Worksheets(a).Cells(b, 1) = x Then
                Worksheets(a).Range(Cells(b, “A”), Cells(b, “K”)).Copy
                Worksheets("Lookup Table").Cells(d, 1).PasteSpecial
                d = d + 1
                End If
            Next b
        End If
    Next a
    MsgBox "Complete"
End Sub

Thank you so much,

with regards,
thomas

 

[Thomas Kuriakose]

Dear All,

I have input some code and it is giving run time error '1004' in the below code -

lastrow1 = Sheets("Lookup Table").Range(“A” & Rows.Count).End(xlUp).Row

Kindly help to correct this error.

Sub Copy()
Dim i As Long, j As Long, lastrow1 As Long, lastrow2 As Long, a As Long
Dim CommissionNumber As String
lastrow1 = Sheets("Lookup Table").Range(“A” & Rows.Count).End(xlUp).Row

For i = 2 To lastrow1
CommissionNumber = Worksheets("Lookup Table").Cells(i, “A”).Value

Worksheets(a).Activate
lastrow2 = Worksheets(a).Range("B" & Rows.Count).End(xlUp).Row

For j = 2 To lastrow2

If Worksheets(a).Cells(j, “B”).Value = CommissionNumber Then
Worksheets(a).Activate
Worksheets(a).Range(Cells(i, "A"), Cells(i, "K")).Copy
Sheets("Lookup Table").Activate
Sheets("Lookup Table").Range(Cells(j, "A"), Cells(j, "K")).Select
ActiveSheet.Paste
End If

Next j
Application.CutCopyMode = False
Next i
Sheets("Lookup Table").Activate
Sheets("Lookup Table").Range("A1").Select
End Sub

thank you so much

with regards,
thomas

 

[Stevie]

Hi Thomas,
try this:

LastRow = Sheets("Lookup Table").Range("A1").CurrentRegion.Rows.Count

Also, worksheets(a) will error more than likely. If your sheet is actually called 'a' then you want worksheets("a"), if it is a number, then you need to give the variable 'a' a value.

 

[Thomas Kuriakose]

Dear Stevie,

Thank you for this valuable input. The run time error is eliminated, but I have again failed to get the desired results from the macro a fifth time.

Kindly help to get the code right to get the output in the Lookup Table sheet.

Please fin attached the file for your reference.

Thank you so much.

with regards,
thomas

 

[Stevie]

Hiya Thomas,
This works for me:

Sub transferdata()
Dim sheetnum As Integer
Dim rownum As Double, rownum2 As Double
Dim com As String, empid As String, empname As String, designation As String
com = Sheets("Lookup Table").Range("A2").Text
rownum = 6
rownum2 = 4
sheetnum = 1
Sheets("Lookup Table").Range("A4:O500").ClearContents
While sheetnum < 4
    empid = Sheets("Sheet" & sheetnum).Range("B1").Text
    empname = Sheets("Sheet" & sheetnum).Range("B2").Text
    designation = Sheets("Sheet" & sheetnum).Range("B3").Text
    While rownum < 737
        If Sheets("Sheet" & sheetnum).Range("B" & rownum).Text = com Then
            Sheets("Sheet" & sheetnum).Range("C" & rownum & ":K" & rownum).Copy
            Sheets("Lookup Table").Range("F" & rownum2).PasteSpecial xlPasteValues
            Sheets("Lookup Table").Range("B" & rownum2) = com
            Sheets("Lookup Table").Range("C" & rownum2) = empid
            Sheets("Lookup Table").Range("D" & rownum2) = empname
            Sheets("Lookup Table").Range("E" & rownum2) = designation
            Sheets("Lookup Table").Range("O" & rownum2) = "Sheet" & sheetnum
            Sheets("Lookup Table").Range("A" & rownum2) = Sheets("Sheet" & sheetnum).Range("A" & rownum).Value
            rownum2 = rownum2 + 1
        End If
        rownum = rownum + 1
    Wend
    sheetnum = sheetnum + 1
    rownum = 6
Wend
End Sub

Paste that ^ into your module and point your button at it and click away.

Note: the macro first clears out the "Lookup Table" down to row 500. This is probably sensible, but if you don't want it, then put a ' in front of the line ending '.clearcontents'.

What you are trying to do, can definitely be done with formula instead of macros, but as you are attempting to solve the problem with macros, I wrote a simply coded solution in VBA. This isn't the most elegant or efficient way to do it, but I'm hoping you can follow what it is doing easily enough, and therefore learn a few things from the process.

If you have any questions on how it works or anything else, let me know.

 

[Thomas Kuriakose]

Dear Stevie,

Firstly thank you so so much for the solution provided with VBA.

As far as understanding the code goes, I am still very very raw in this field, I am trying to learn, but nothing seems to go into my head.

Question:
1. If we have more than 3 sheets can I increment this? (In the actual data there are more than 30 sheets)
2. If there are more values in columns can we still use this code? In the actual data there are additional 4 more columns of data)

Secondly, I tried using the vlookup across multiple sheets function, here I again I failed.

Kindly find attached the formula I used.

Thanks a ton once again for he much needed support on this.

with regards,
thomas

 

[Stevie]

Hiya Thomas,
I don't have time to work on a formula solution for you at the moment sorry, perhaps one of the resident ninjas might.

If you have more sheets and they are all named "Sheet1", "Sheet2"...etc, then you can replace the 4 in:

While sheetnum < 4

with the number of your last sheet + 1.
So if you have 30 sheets and the last one is "Sheet30" then make that number in the code above 31.
If by more columns, you mean more columns of Ys and blanks you want to copy, then yes, just change the letters in:

Sheets("Sheet" & sheetnum).Range("C" & rownum & ":K" & rownum).Copy

to the correct letters.
If you range goes up to column P for example, and you need to copy from column C to column P every time, then change the code above to:

Sheets("Sheet" & sheetnum).Range("C" & rownum & ":P" & rownum).Copy

In order to learn VBA, you need to start simple and practice. Try some courses/tutorials online if you want.

If you want to be sure it will work with 'Actual Data' then you need to provide a comparable example and explain it's limits and expected working boundaries fully. Without this, I can't ever be sure it will work for you as I don't know what it needs to do.

Hope this answers your questions

 

[Thomas Kuriakose]

Dear Stevie,

Thank you so much for all the valuable inputs.

I am trying to grasp with a lot of reading on excel these days and hope to get some hold on this.

Thanks once again.

with regards,
thomas

 

[Pavan.Sada.PS]

Hello Thomas,

Pls check if the attached file fulfills your request.

Regards,
Pavan S

 

[Thomas Kuriakose]

Dear Pavan,

Thank you so much for the solution provided. This is working fine.

Thanks once again.

with regards,
thomas