Vba To Copy Data From Wkbk1 To Wkbk2

[timbo1957]

I need a macro that will do the following on the attached example.

Run down Column B and for every instance of 01|13 copy the adjacent isbn in column C.

For 01|13 entries paste the copied data as values into another workbook called Workbook 2 in cell A10, then A11 etc.

For 02|13 entries paste the copied data as values into another workbook called Workbook 2 in cell A60, then A61 etc.

For 03|13 entries paste the copied data as values into another workbook called Workbook 2 in cell A110, then A111 etc.

i.e. every time the month changes by 1 jump down to A60 then A110 then A160 etc.

Sometimes these ranges change so it would be helpful if the first cell for each month to be pasted into it is defined in the macro i.e. Range("A10").Select for example. Rather than just assuming the data will be 50 rows apart.

This is one sheet of a set and some sheets don't have 01|13 throught to 04|13 and there are other variations so the macro needs to be able to work out that if the number in B6 is 05|13 it needs to paste into A210.

I have given an example on sheet 2 of the attached example.

Many thanks.

[venkat1926]

KEEP BOTH THE WORKBOOKS WKBK1 AND WKBK2 OPEN
park these macros in the vbeditor of workbook wkbk1

now try this macro "test"(macro undo is to clear wkbk2 so that you can retest)

for redesigning the various parameters see the comments agianst the various variables carefully.

Sub test()
Dim j As Integer, k As Integer, r As Range, x As String
Dim m As Integer, n As Integer

k = 11
'k is larget number with /13 and if necessary change it
m = 10 'the first row in which to be copied.if necessary change
n = 50 'difference between te rows in your case it is 50. if necessary change
Workbooks("wkbk1.xls").Activate
Worksheets("test").Activate
Set r = Range(Range("A1"), Cells(Rows.Count, "c").End(xlUp))
'MsgBox r.Address
For j = 1 To k
If j < 10 Then
x = "0" & j & "|13"
Else
x = j & "|13"
End If
'MsgBox x
r.AutoFilter Field:=2, Criteria1:=x
r.Offset(1, 0).Resize(r.Rows.Count - 1, r.Columns.Count).SpecialCells(xlCellTypeVisible).Copy
With Workbooks("wkbk2.xls").Worksheets("sheet1")
'MsgBox .Range("A" & m).Offset((j - 1) * n, 0).Address
.Range("A" & m).Offset(m + (j - 1) * n, 0).PasteSpecial Paste:=xlPasteValues
End With
'Workbooks("wkbk1.xls").Activate
'Worksheets("test").Activate


r.AutoFilter
Next j
End Sub

Sub undo()
With Workbooks("wkbk2.xls").Worksheets("sheet1")
.Cells.Clear
End With
End Sub

[timbo1957]

This part of the macro is picking up the range A:C instead of just C.

r.Offset(1, 0).Resize(r.Rows.Count - 1, r.Columns.Count).SpecialCells(xlCellTypeVisible).Copy

[timbo1957]

If anyone can help with my last post re this problem I would be grateful.

[timbo1957]

Can someone help me with this please?

The macro was kinldy supplied by a member of the forum. I think that this part of the macro is picking up columns A:C rather than just column C.

Can anyone advise on how to change it please?

r.Offset(1, 0).Resize(r.Rows.Count - 1, r.Columns.Count).SpecialCells(xlCellTypeVisible).Copy

Sub test()
Dim j As Integer, k As Integer, r As Range, x As String
Dim m As Integer, n As Integer

k = 11
'k is larget number with /13 and if necessary change it
m = 10 'the first row in which to be copied.if necessary change
n = 50 'difference between te rows in your case it is 50. if necessary change
Workbooks("wkbk1.xls").Activate
Worksheets("test").Activate
Set r = Range(Range("A1"), Cells(Rows.Count, "c").End(xlUp))
'MsgBox r.Address
For j = 1 To k
If j < 10 Then
x = "0" & j & "|13"
Else
x = j & "|13"
End If
'MsgBox x
r.AutoFilter Field:=2, Criteria1:=x
r.Offset(1, 0).Resize(r.Rows.Count - 1, r.Columns.Count).SpecialCells(xlCellTypeVisible).Copy
With Workbooks("wkbk2.xls").Worksheets("sheet1")
'MsgBox .Range("A" & m).Offset((j - 1) * n, 0).Address
.Range("A" & m).Offset(m + (j - 1) * n, 0).PasteSpecial Paste:=xlPasteValues
End With
'Workbooks("wkbk1.xls").Activate
'Worksheets("test").Activate

r.AutoFilter
Next j
End Sub