Copy data based on cell value with selection of what to copy

[1Ronin]

Hello,


I have one macro that is copy rows from a master sheet to another sheet depending on cell values from column D.
There is a link between the cell value (in my macro is now 10001) and sheet name (St1).
The values could variate from 10001/St1 .... 10010/St10.
My questions are:
- How could I have a message at beginning of macro to select/input a specific value (1...10) and avoid to change macro all time (by replacing 10001 with 10007 for example)?
- How could I have a message at beginning of macro to select/input to copy all data (1...10) and not only a single value (for ex. 10005)?

Sub Copy1ST()

'Select older extracted data a deletes them; to modfy size if anything changes
    Sheets("St1").Activate
    Range("B2:XFD2000").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    
 
Set i = Sheets("Data")
Set e = Sheets("St1")
Dim d
Dim j
d = 1
j = 2


Do Until IsEmpty(i.Range("D" & j))


    If i.Range("D" & j) = "10001" Then
    d = d + 1
    e.Rows(d).Value = i.Rows(j).Value
       
    End If
    j = j + 1
Loop


'delete first column data not interesting for us
    Sheets("St1").Select
    Range("A2:A2000").Select
    Selection.Delete Shift:=xlToLeft
    Range("A2").Select




MsgBox "Done!!!"


End Sub

Thank you for your time.

 

[vcoolio]

Hello 1Ronin,

Rather than use a loop type construct, following is a code that uses autofilter:

Sub Test()

        Dim ws As Worksheet: Set ws = Sheets("Data")
        Dim sh As Worksheet: Set sh = Sheets("St1")
        Dim vSrch As String

vSrch = InputBox("Please enter a value from Column D to search for.")
If vSrch = vbNullString Then Exit Sub

Application.ScreenUpdating = False

With ws.[A1].CurrentRegion
        .AutoFilter 4, vSrch
        .Offset(1).EntireRow.Copy
        sh.Range("A" & Rows.Count).End(3)(2).PasteSpecial xlValues
        .AutoFilter
End With

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

On running the code, an Input Box will appear asking you to enter a value from Column D to filter on. Once you enter a value and click on OK, the relevant rows of data will be transferred to sheet "St1". With the "Data" sheet, I'm also assuming that your data starts in row2 with headings in row1.

You won't have to alter the code to suit new values.

I hope that this helps.

Cheerio.
vcoolio.

 

[1Ronin]

Hi vcoolio,

The code is not ok, maybe because data starts in row2 column B...headings are in row1 .
Anyway, just for me to learn (rookie....) please explain line by line what is doing the following code:

[COLOR=#333333]With ws.[A1].CurrentRegion[/COLOR]
        .AutoFilter 4, vSrch
        .Offset(1).EntireRow.Copy
        sh.Range("A" & Rows.Count).End(3)(2).PasteSpecial xlValues
        .AutoFilter [COLOR=#333333]End With[/COLOR]

Thanks.

 

[vcoolio]

Hello 1Ronin,

First of all, we need to sort out why the code isn't quite working for you.

Based on what you have said in post #3 , change this line:-

With ws.[A1].CurrentRegion

to

With ws.[B1].CurrentRegion

You will also need to change the 4 in this line:-

.AutoFilter [COLOR=#ff0000]4[/COLOR], vSrch

to 3.


I'm now assuming that Column A is empty.

Cheerio,
vcoolio.

 

[1Ronin]

vcoolio,

Still not working after above modifications...
Column A in Data sheet is not empty, has some parameters that I need for other macro that is running before this one. This column has not to be touch or modified.
The data that is interesting for me is starting from B2. The sorting is done by column D values.
Sorry if I confused you or not give complete info from beginning.

 

[vcoolio]

Hello 1Ronin,

It would be best if you uploaded a sample of your file to a free file sharing site (such as Drop Box) and then post the link to your file back here. Make sure that the sample is an exact replica of your workbook and if your data is sensitive then please use dummy data. A dozen or so rows of data will suffice in the sample.

This will make it much easier for us to help you.

Cheerio,
vcoolio.

 

[Fluff]

How about

Sub FltrCopy()
   Dim Ws1 As Worksheet, Ws2 As Worksheet
   
   Set Ws1 = Sheets("Data")
   Set Ws2 = Sheets("St1")
   
   Ws2.Range("B2:XFD" & Rows.Count).ClearContents
   With Ws1
      If .AutoFilterMode Then .AutoFilterMode = False
      .Range("A1:Z2000").AutoFilter 4, "10001"
      .AutoFilter.Range.Offset(1).EntireRow.Copy Ws2.Range("A2")
      .AutoFilterMode = False
   End With
End Sub

 

[1Ronin]

Hi Fluff,


Thanks for code. Is working.
Also, in the end the code from vcoolio works... I think it was an error with filtering mode or so in my laptop.

In the end I combine both codes and is almost perfect... still missing the option to send correct data (1000x) to correct sheet (Stx).
Normally I have all sheets St1...St10 in the workbook and data should be send to correct sheet, not only to St1.
As it is now I can copy all data 10001...10010, but only to St1 sheet.
How can I copy data 1000x to correct Stx sheet?

The code adapted is looking like:

Sub FltrCopy()   Dim Ws1 As Worksheet, Ws2 As Worksheet
   
   Set Ws1 = Sheets("Data")
   Set Ws2 = Sheets("St1")
   
   Dim vSrch As String


vSrch = InputBox("Please enter a value from Column D to search for.")
If vSrch = vbNullString Then Exit Sub


Application.ScreenUpdating = False
   
   Ws2.Range("B2:XFD" & Rows.Count).ClearContents
   With Ws1
      If .AutoFilterMode Then .AutoFilterMode = False
      .Range("A1:Z2000").AutoFilter 4, vSrch
      .AutoFilter.Range.Offset(1).Range("B1:ZZ2000").Copy Ws2.Range("A2")
      .AutoFilterMode = False
   End With
End Sub

Thanks.

 

[Fluff]

How about

Sub FltrCopy()
   Dim Ws1 As Worksheet, Ws2 As Worksheet
   Dim vSrch As String
   
   Set Ws1 = Sheets("pcode")

   vSrch = InputBox("Please enter a number from 1 to 10.")
   If vSrch = vbNullString Then Exit Sub
   Set Ws2 = Sheets("St" & vSrch)
   vSrch = 10000 + vSrch
   
   Application.ScreenUpdating = False
   
   Ws2.Range("B2:XFD" & Rows.Count).ClearContents
   With Ws1
      If .AutoFilterMode Then .AutoFilterMode = False
      .Range("A1:Z2000").AutoFilter 4, vSrch
      .AutoFilter.Range.Offset(1).Range("B1:ZZ2000").Copy Ws2.Range("A2")
      .AutoFilterMode = False
   End With
End Sub

But enter a number from 1 to 10 in the inputbox, rather then the number to filter on.

 

[1Ronin]

Not run (yet)...
Is give below error:
"Run-time error 9: subscript out of range"

Is stop at line:

   Set Ws1 = Sheets("pcode")