Finding a datakey and copying data from that row to another sheet

[davefish]

I have data that is extracted from a source using a query. This data has a datakey at column "J" and if it's populated by the character "H" then columns "A", "C" and "E" of that row, are copied to a row in another sheet. I have two issues that hopefully someone can help with:-

a) I can loop through the rows and detect the datakey, but cannot seem to get the copy of none adjacent cells to work propery.

b) The other issue relates to pasting this data. The sheet has a colum header that designates the region as an example the first sub-header USA (Row1) , maybe followed by 10 rows of USA data, this to be followed by a sub-header called EUROPE (Row 12). If this is to be a dymanic sheet and the number of rows changes how can I: -

i) ensure no blanks rows
ii) ensure I don't write over the next sub-header.

Can anyone start me on this please as I'm going round in circles!

 

[PHV]

What have you tried so far and where in your code are you stuck ?

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[davefish]

Hi PH,

To explain further I have five worksheets in the file, four of which hold regionally specific data that I wish to summarise in a separte worksheet if the datakey "H" is present in column "H". I can loop through and select data from the first sheet using the code below, but cannot seem to get the other sheets to work correctly. To complicate the whole afair, I want to sub total each region in the same table on worksheet "Summary" Heres the code as is: -

Sub DataSummary()
Dim x As Integer
Dim y As Integer
Dim ws1, ws2, ws3, ws4, ws5 As Worksheet


Set ws1 = Worksheets("Summary") 'Summary Sheet, destination of results
Set ws2 = Worksheets("Middle East") 'Data source Middle East
Set ws3 = Worksheets("Europe") 'Data source Europe
Set ws4 = Worksheets("ASEAN") 'Data source ASEAN
Set ws5 = Worksheets("Americas") 'Data source Americas


r = 1 'First row for output data
x = 1 'First row to check data
Do Until ws2.Range("A" & x) = "" 'Loop until column A is empty.


If Not ws2.Range("k" & x).Value = "" Then 'Checks column K to make sure it's not empty
'If empty, it goes on to the next line, if not it copies the data.

'Copies data to the results sheet
ws1.Range("A" & r).Value = ws2.Range("A" & x).Value
ws1.Range("B" & r).Value = ws2.Range("B" & x).Value
ws1.Range("C" & r).Value = ws2.Range("C" & x).Value
ws1.Range("D" & r).Value = ws2.Range("D" & x).Value
ws1.Range("E" & r).Value = ws2.Range("E" & x).Value
ws1.Range("F" & r).Value = ws2.Range("F" & x).Value
ws1.Range("G" & r).Value = ws2.Range("G" & x).Value
ws1.Range("H" & r).Value = ws2.Range("H" & x).Value
ws1.Range("I" & r).Value = ws2.Range("I" & x).Value
ws1.Range("J" & r).Value = ws2.Range("J" & x).Value
ws1.Range("K" & r).Value = ws2.Range("K" & x).Value
ws1.Range("L" & r).Value = ws2.Range("L" & x).Value
ws1.Range("M" & r).Value = ws2.Range("M" & x).Value

r = r + 1
x = x + 1
Else
x = x + 1
End If
Loop


End Sub

 

[zelgar]

replace your current code after x=1 with the following:

Do Until IsEmpty(ws.cell(x, 1))
    If ws2.cell(x, 10) <> "" Then
        Range(ws2.Cells(x, 1), ws2.Cells(x, 12)).Copy _
            Destination:=ws1.Cells(r, 1)
        r = r + 1
    End If
    x = x + 1
Loop

 

[davefish]

Hi Zelgar,

I get an error message when I try this "Runtime error 424". This scritp replaced the that from x =1 all the way to End Sub

Dave

 

[zelgar]

Sorry...
change
If ws2.cell(x, 10) <> "" Then
to
If ws2.Cells(x, 10) <> "" Then

 

[davefish]

Still not joy I'm afraid I get an "Object required" error now on Do Until IsEmpty(ws.cell(x, 1))

 

[SkipVought]

Cell[red]s[/red]

Skip,
[sub]
Just traded in my old subtlety...
for a NUANCE![/sub]

 

[davefish]

Hi Skip,

I checked all the cell Vs cells but it still highlights the "Do Until IsEmpty(ws.Cells(x, 1))" line as requiring an object? Here's the complete code I'm using: -

Public Sub DataSummary()
Dim x As Integer
Dim y As Integer
Dim ws1, ws2 As Worksheet


Set ws1 = Worksheets("Summary") 'Summary Sheet, destination of results
Set ws2 = Worksheets("Middle East") 'Data source Middle East


r = 1 'First row for output data
x = 1 'First row to check data

Do Until IsEmpty(ws.Cells(x, 1))
If ws2.Cells(x, 10) <> "" Then
Range(ws2.Cells(x, 1), ws2.Cells(x, 12)).Copy _
Destination:=ws1.Cells(r, 1)
r = r + 1
End If
x = x + 1
Loop

End Sub


Dave

 

[SkipVought]

what is the value of x when you get the Debug?

What VERSION of Excel?

Please answer both.

Skip,
[sub]
Just traded in my old subtlety...
for a NUANCE![/sub]

 

[zelgar]

As the others have mentioned, all of the Cell should be Cells in the 2 lines (Do & IF statements)

Also, Do Until IsEmpty(ws.Cells(x, 1)) should be Do Until IsEmpty(ws2.Cells(x, 1))

 

[davefish]

Hi Skip,

X =1. I'm Office 2010 version 14.0.6129.5000 32 bit running on Windows 7 32 bit

Regards

Dave

 

[SkipVought]

BTW...

Dim ws1, ws2 As Worksheet

Your declaration states, declare ws1 as VARIANT (the default) and ws2 as Worksheet.

Preceeding declarations in the same line, do NOT inherit the last explicit data type. The implicit data type is VARIANT.

So I'd venture a guess that what you meant is

Dim ws1 As Worksheet, ws2 As Worksheet

Skip,
[sub]
Just traded in my old subtlety...
for a NUANCE![/sub]

 

[davefish]

As an aside, my earlier code did work, and I could run this for each sheet in the workbook separately, but it overwrote the data from other sheets in the summary sheet. I'm trying to summerise the data from four works sheets as a continuous list, so I tried to sue end(xldown) but again this threw up errors?

 

[zelgar]

Dave, try this code to do all the things I think you want:

For y = 1 To 4
    ws2 = Choose(y, "Middle East", "Europe", "ASEAN", "Americas")
    Do Until IsEmpty(ws2.Cells(x, 1))
        If ws2.Cells(x, 10) <> "" Then
            Range(ws2.Cells(x, 1), ws2.Cells(x, 12)).Copy _
                Destination:=ws1.Cells(r, 1)
            r = r + 1
        End If
        x = x + 1
    Loop
Next y

 

[zelgar]

Oops.... Forgot to reset x in the code....

For y = 1 To 4
    ws2 = Choose(y, "Middle East", "Europe", "ASEAN", "Americas")
    [b]x = 1[/b]
    Do Until IsEmpty(ws2.Cells(x, 1))
        If ws2.Cells(x, 10) <> "" Then
            Range(ws2.Cells(x, 1), ws2.Cells(x, 12)).Copy _
                Destination:=ws1.Cells(r, 1)
            r = r + 1
        End If
        x = x + 1
    Loop
Next y

 

[SkipVought]

BTW,
IsEmpty is used to determine if individual variables are initialized.

Rather, what you need is something like...

Do Until ws.Cells(x, 1).Value = ""
  If ws2.Cells(x, 10) <> "" Then
     Range(ws2.Cells(x, 1), ws2.Cells(x, 12)).Copy _
     Destination:=ws1.Cells(r, 1)
     r = r + 1
  End If
  x = x + 1
Loop

or, using End

dim rg as range

for each rg in range(ws2.Cells(x, 1), ws2.Cells(x, 1).end(xldown)
  If ws2.Cells(rg.row, 10) <> "" Then
     intersect(rg.row, ws2.usedrange).Copy _
        Destination:=ws1.Cells(r, 1)
     r = r + 1
  End If
next

Skip,
[sub]
Just traded in my old subtlety...
for a NUANCE![/sub]

 

[zelgar]

Skip, I think you need to add another ) to the end of this line:
for each rg in range(ws2.Cells(x, 1), ws2.Cells(x, 1).end(xldown)

 

[SkipVought]

@zelgar, yes, thnx!

for each rg in range(ws2.Cells(x, 1), ws2.Cells(x, 1).end(xldown))
 

]code]

Skip,
[sub]
[glasses]Just traded in my [b]old subtlety[/b]...
for a [b]NUANCE![/b][tongue][/sub]

 

[zelgar]

Dave, the following are complete codes for Skip's and my version of your macro:
Skip's

Sub DataSummary()
Dim r As Integer, x As Integer, y As Integer
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rg As Range
r = 1                                                                   ' First row for output data
Set ws1 = Worksheets("Summary")                                         ' Summary Sheet, destination of results

For y = 1 To 4                                                          ' Loop for all Source Sheets
    ws2 = Choose(y, "Middle East", "Europe", "ASEAN", "Americas")       ' Data Source Sheets
    x = 1                                                               ' First Row of data
    For Each rg In Range(ws2.Cells(x, 1), ws2.Cells(x, 1).End(xlDown))  ' Loop until Column A is empty
        If ws2.Cells(rg.Row, 10) <> "" Then                             ' If Column K is not empty, copy data from Col A to M
            Intersect(rg.Row, ws2.UsedRange).Copy _
                Destination:=ws1.Cells(r, 1)
            r = r + 1
        End If
    Loop
Next y
End Sub

and mine

Sub DataSummary()
Dim r As Integer, x As Integer, y As Integer
Dim ws1 As Worksheet, ws2 As Worksheet
r = 1                                                                   ' First row for output data
Set ws1 = Worksheets("Summary")                                         ' Summary Sheet, destination of results

For y = 1 To 4                                                          ' Loop for all Source Sheets
    ws2 = Choose(y, "Middle East", "Europe", "ASEAN", "Americas")       ' Data Source Sheets
    x = 1                                                               ' First Row of data
    Do Until IsEmpty(ws2.Cells(x, 1))                                   ' Loop until Column A is empty
        If ws2.Cells(x, 10) <> "" Then                                  ' If Column K is not empty, copy data from Col A to M
            Range(ws2.Cells(x, 1), ws2.Cells(x, 12)).Copy _
                Destination:=ws1.Cells(r, 1)
            r = r + 1
        End If
        x = x + 1
    Loop
Next y
End Sub