Moving through a list

  • Thread starter Thread starter Gerard Goodland
  • Start date Start date
G

Gerard Goodland

Hi all,

Below is the macro that I have put together from , recording, some from
help I got here and some of it I done. The sheet "Contacts" has aprox
300 rows of contact info that I need to copy and paste into the sheet
called "Inventory" in the same workbook.I then save the "Inventory"
sheet to a new workbook and save it with the name of the file comming
from cell 'X4".I then save and close this new workbook.Now I need to go
back to the original workbook " Contacts" sheet and move down to the
next row and do it all over again until there are no more entries left
in the " Contacts" sheet. I hope that is not too confusing. I have got a
lot of help here in the last few days and I really appreciate it.

Thanks


Dim myRow As Long
Sheets("Contacts").Select
For myRow = 1 To .Range("A65536").End(xlUp).Row
Range("B7").Select
Selection.Copy
Sheets("Inventory").Select
Range("D4").Select
ActiveSheet.Paste
Sheets("Contacts").Select
Application.CutCopyMode = False
Range("C7").Select
Selection.Copy
Sheets("Inventory").Select
Range("D5").Select
ActiveSheet.Paste
Sheets("Contacts").Select
Application.CutCopyMode = False
Range("D7").Select
Selection.Copy
Sheets("Inventory").Select
Range("D6").Select
ActiveSheet.Paste
Range("D7").Select
Sheets("Contacts").Select
Application.CutCopyMode = False
Range("E7").Select
Selection.Copy
Sheets("Inventory").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Sheets("Contacts").Select
Range("A7").Select
Selection.Copy
Sheets("Inventory").Select
Range("X4").Select
ActiveSheet.Paste
Sheets("Contacts").Select
Range("F7:G7").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Inventory").Select
Range("W6").Select
ActiveSheet.Paste
Sheets("Contacts").Select
Application.CutCopyMode = False
ActiveWindow.SmallScroll ToRight:=3
Sheets("Inventory").Select
Range("X4").Select


Sheets("Inventory").Select
Sheets("Inventory").Copy
ActiveWorkbook.SaveAs _
Filename:=ActiveWorkbook.Worksheets(1).Range("x4").Value
ActiveWorkbook.Close SaveChanges:=True

Next myRow




End Sub
 
Gerard

I hate trying to follow other peoples code, but I suspect the code below
will do what you are trying. (Test it on draft data first). In VBA there is
seldom need to select anything and then work on the 'Selection', you can do
it on the object directly.

The code takes the data in the first row of the contacts sheet, range B1:E1
and paste special+transposes it to the Inventory sheet Range D4:D7 (Presume
this remains static during each iteration). Takes the value in A1 on the
contacts sheet and assigns it to X4 on the inventory sheet. Takes the value
in the range F1:G1 on the contacts sheet and assigns it to W6:X6 on the
inventory sheet (again I presume this doesn't change). It then copies the
inventory sheet to a new workbook and saves that as the value in X4 on the
inventory sheet (To the default save directory). It then closes the new
workbook, clears the variable that held it and repeats with the second row
on the contacts sheet. It continues this cycle until the last row on the
contacts sheet.

This may throw a dialog if two file names are the same and it may error as I
have only tested with 5 lines of data

See how you get on.

Sub MoveDataAndSave()
Dim wksContact As Worksheet, wksInventory As Worksheet
Dim NewWb As Workbook
Dim lLastRow As Long, cntr As Long
Dim sFileName As String

Set wksContact = Worksheets("Contacts")
Set wksInventory = Worksheets("Inventory")

lLastRow = wksContact.Range("A65536").End(xlUp).Row

For cntr = 1 To lLastRow
wksContact.Range("B" & cntr & ":E" & cntr).Copy
wksInventory.Range("D4").PasteSpecial Transpose:=True
wksInventory.Range("X4").Value = wksContact.Range("A" & cntr).Value
wksContact.Range("F" & cntr & ":G" & cntr).Copy _
Destination:=wksInventory.Range("W6:X6")


wksInventory.Copy
Set NewWb = ActiveWorkbook
sFileName = wksInventory.Range("X4").Value
NewWb.SaveAs Filename:=sFileName
NewWb.Close SaveChanges:=False
Set NewWb = Nothing
Next cntr
End Sub



--
HTH
Nick Hodge
Microsoft MVP - Excel
Southampton, England
(e-mail address removed)
 
Back
Top