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!

 

[SkipVought]

Should be

    Set ws2 = Sheet(Choose(y, "Middle East", "Europe", "ASEAN", "Americas"))       ' Data Source Sheets

since ws2 is a Worksheet object and not a string.

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

 

[zelgar]

I knew I was forgetting something. Thanks for the correction, Skip

 

[SkipVought]

I'd suggest...

for each ws2 in worksheets
  with ws2
    select case .name
      case "Middle East", "Europe", "ASEAN", "Americas"
        For Each rg In Range(.Cells(x, 1), .Cells(x, 1).End(xlDown))  ' Loop until Column A is empty
            If .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
    end select
  end with
next

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

 

[zelgar]

Skip, since you're not changing the value for x in your code, do you need it to be a varible in the following:
For Each rg In Range(.Cells(x, 1), .Cells(x, 1).End(xlDown))
and replace it with
For Each rg In Range(.Cells(1, 1), .Cells(1, 1).End(xlDown))

 

[SkipVought]

Whatever that FIRST value of x happens to be.

Also I almost never see range start in row 1 in my workbooks. Row 1 is almost always a header row.

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

 

[davefish]

Hi Skip,

Thank you for your advice so far. I tried the script but keep getting a "Loop Without Do" error message. I noticed there was no do statement so tried removing it only to get an "End Select with Select case Statement " error.

Zelgar, I also tried your script to find an error message "Object variable or with variable not set".

It seems strange that I get error in both VB's, so could it be something on my setup?

Regards

Dave

 

[SkipVought]

Sorry, substitute Next for Loop, ie Do...Loop or For...Next.

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

 

[davefish]

Hi Skip,

Perhaps it's me, but...

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

For Each ws2 In Worksheets
With ws2
Select Case .Name
Case "Middle East", "Europe", "ASEAN", "Americas"
For Each rg In Range(.Cells(x, 1), .Cells(x, 1).End(xlDown)) ' Loop until Column A is empty
If .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
End Select
End With
Loop

End Sub

This still gives me "Loop without Do" error ?
Dave

 

[zelgar]

Dave, did you use my original code or the correction Skip provided

Set ws2 = Sheet(Choose(y, "Middle East", "Europe", "ASEAN", "Americas"))       ' Data Source Sheets

Also, as Skip indicated, if you're using his code, you need to replace the Loop with Next. The First "Loop" with "Next rg", and the 2nd "Loop" with "Next ws2

 

[davefish]

Hi Zelgar,

As I was unsure which correction went with which code, so I tried combinations of the two. What I mean is your coded as is, followed by your code with Skip's correction, then finally with Skips code etc. I seem to get error messages whichever way I try it. Can you get this to work on your setup?

4 sheets of data summarising to a fifth?

Regards

Dave

 

[zelgar]

Skip's change wasn't exactly correct, it should be the following:

Set ws2 = Worksheets(Choose(y, "Middle East", "Europe", "ASEAN", "Americas"))       ' Data Source Sheets

 

[davefish]

Hi Zelgar,

That works great thank you, but is there any way of identifying which region they came from as each tab is a different set of data? If I can insert a sub header for each in the table ASEAN, Americas etc that would do me just fine.

Regards

Dave

 

[zelgar]

If you want a line to state the names of the sections in Col A before the data, enter the following code after the line x = 1

Cells(r,1) = Choose(y, "Middle East", "Europe", "ASEAN", "Americas")
r = r + 1

It'll probably be better if you had a column indicating the name of the data source, if so, modify the following code:
Puts the data source name in Column N

Range(ws2.Cells(x, 1), ws2.Cells(x, 12)).Copy _
    Destination:=ws1.Cells(r, 1)
ws1.Cells(r,13) = Choose(y, "Middle East", "Europe", "ASEAN", "Americas")
r = r + 1

OR
Puts the data source name in Column A and the other data in Cols B - N

Range(ws2.Cells(x, 1), ws2.Cells(x, 12)).Copy _
   Destination:=ws1.Cells(r, 2)
ws1.Cells(r,1) = Choose(y, "Middle East", "Europe", "ASEAN", "Americas")
r = r + 1

 

[davefish]

Hi Zelgar,

The first option looks good to me. I have added a bit a code to try and sum the values per region as follows: -

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

For y = 1 To 4 ' Loop for all Source Sheets
Set ws2 = Worksheets(Choose(y, "Middle East", "Europe", "ASEAN", "Americas")) ' Data Source Sheets
x = 2 ' First Row of data
Cells(r, 1) = Choose(y, "Middle East", "Europe", "ASEAN", "Americas")
Cells(r, 4) = Choose(y, "Q", "B", "C", "D")

r = r + 1
Do Until IsEmpty(ws2.Cells(x, 2)) ' Loop until Column A is empty
If ws2.Cells(x, 11) <> "" 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

/code

you'll notice I moved the row to accommodate a single header but am having problems summing I think the code is worksheetFunction.SUM(R[1]C:R[6]C) would that work per region?

Cheers

Dave

 

[zelgar]

There's several ways of doing this. The easiest method would be to lable all of the entries with the worksheet name, so you could use the Outline tools.

Otherwise, I would have the calculation being done during your macro loop, by adding the following lines:
1. Add a DIM statement for new variables (e.g., Dim sumA)
2. In the FOR loop & Before the Do Unitl Statement, set the variable to 0 (e.g., sumA = 0)
3. Within the IF command & Before the Then, add the data to your variable (e.g., sumA = sumA + ws1.Cells(r, 1) )
4. After the Loop command & Before the Next Y, insert the total & increase r counter (e.g., ws1.Cells(r, 1) = sumA, r = r + 1)

 

[davefish]

Hi Zelgar,

I'm not a great fan of the outline tools so I'll have a go at the code. I'll come back to you whatever. Many Thanks

Dave

 

[davefish]

Hi Zelgar,

If I've understood you correctly it looks like this, but I do get errors

Have I screwed this up?

Regards

Dave

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

r = 2                                                                  ' First row for output data
Set ws1 = Worksheets("Summary")                                         ' Summary Sheet, destination of results

For y = 1 To 4                                                          ' Loop for all Source Sheets
    Set ws2 = Worksheets(Choose(y, "Middle East", "Europe", "ASEAN", "Americas"))        ' Data Source Sheets
    x = 2 ' First Row of data
   Cells(r, 1) = Choose(y, "Middle East", "Europe", "ASEAN", "Americas")
   Cells(r, 4) = Choose(y, "Q", "B", "C", "D")

r = r + 1
SumA = 0
    Do Until IsEmpty(ws2.Cells(x, 2))                                   ' Loop until Column A is empty
        If ws2.Cells(x, 11) <> "" And SumA = SumA + ws1.Cells(r, 1) Then                                  ' If Column K is not empty, copy data from Col A to M
            Range(ws2.Cells(x, 1), ws2.Cells(x, 8)).Copy _
                Destination:=ws1.Cells(r, 1)
            r = r + 1
        End If
        x = x + 1
    
    Loop
    
ws1.Cells(r, 1) = sumA, r = r + 1)
 
Next y

End Sub

 

[zelgar]

change the

If ws2.Cells(x, 11) <> "" And SumA = SumA + ws1.Cells(r, 1) Then 
            Range(ws2.Cells(x, 1), ws2.Cells(x, 8)).Copy _
                Destination:=ws1.Cells(r, 1)

to

If ws2.Cells(x, 11) <> "" Then
            Range(ws2.Cells(x, 1), ws2.Cells(x, 8)).Copy _
                Destination:=ws1.Cells(r, 1)
            SumA = SumA + ws1.Cells(r, 1)

AND

ws1.Cells(r, 1) = sumA, r = r + 1)

to

ws1.Cells(r, 1) = sumA 
r = r + 1