most efficient wat to QUICKLY paste values to another book.

Hello,

For past couple of months, i am learning VBA basics and i figured that often there are more than a couple of ways for getting same results.

I have few codes from my old workbooks, some are pathetically slow at pasting and some are very efficient.

I have attached a workbook with 2 sheets. "Master" sheet contains clinical data of patients. 1 row per patient and "clinical" sheet is how report of the patient is generated on an A4 size page.

I am trying to do the following:

1. Make a copy of sheet "clinical" at path D:\xyz\xyz\1.xlsx --- 1 being Sr No, serial number of the row as in column A.
2. Copy (paste special values) contents from master sheet row 1, to 1.xlsx created.
3. Save file ---> Close.
4. Create 2.xlsx to paste values from row 2 "master". ---> Save close, 3.xlsx and so on..

So if i have 500 rows, i will have 500 individual workbooks of patients in a folder named as 1.xlsx,2.xlsx,3.xlsx...and so on..

--> I want to paste special VALUES only.
--> Also paste if some cells in a row are empty.
--> Overwrite if destination file exists.

In code i use, macro always runs from beginning and recreates all 500 files again. For eg, if i create a new row 501 for new patient and i want to generate only 501.xlsx, my code runs from beginning and creates 500 existing files again. Anyway to paste only selected rows? I can select Sr Nos that are contiguous and macro will only create workbooks for those selected Sr Nos.

Please Note: In sheet clinical i have already created a table with cell reference. (Where to paste what)

Some of the slow and efficient codes i was using earlier for other reports are as follows:

Slow: It's long i have just posted part of the code.

Sub Report()
' hay Macro
'
' Keyboard Shortcut: Ctrl+h
'
       
    Dim f As String
    Dim ii As String
    Dim r As String
    Dim ri As String
    Dim Path As String
    
    'Turn screen updating off. You won't see the client file being updated.
Application.ScreenUpdating = False

    

   
   
   ' path to your folder
    Path = "D:\excelreport\ROUTINE\"
    
    i = 1
    x = Cells(i + 1, 1)
    
    Do While x <> Empty
    
    ii = i
    f = ii + ".xlsx"
   
      
    Workbooks.Open FileName:=Path & "NEW-ROUTINE.xlsx"
    Windows("NEW-ROUTINE.xlsx").Activate
    ActiveWorkbook.SaveCopyAs FileName:=Path & f
    Workbooks.Open FileName:=Path & f
    
   
    ri = i + 1
    
    Windows("ROUTINE.xlsm").Activate
    
    
    r = "A" & ri
    Range(r).Select
    Selection.Copy
    Windows(f).Activate
    Range("C9").Select
    ActiveSheet.Paste
    Windows("ROUTINE.xlsm").Activate
    
    r = "B" & ri
    Range(r).Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows(f).Activate
    Range("F9").Select
    ActiveSheet.Paste
    Windows("ROUTINE.xlsm").Activate
    
    r = "C" & ri
    Range(r).Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows(f).Activate
    Range("I10").Select
    ActiveSheet.PasteSpecial xlPasteValuesAndNumberFormats
    Windows("ROUTINE.xlsm").Activate
    
    r = "D" & ri
    Range(r).Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows(f).Activate
    Range("I8").Select
    ActiveSheet.Paste
    Windows("ROUTINE.xlsm").Activate
 r = "AU" & ri
    Range(r).Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows(f).Activate
    Range("I49").Select
    ActiveSheet.Paste
    
   ActiveWorkbook.Save
   ActiveWorkbook.Close
 
    Windows("ROUTINE.xlsm").Activate
    i = i + 1
    x = Cells(i + 1, 1)
    Loop
    
    Windows("NEW-ROUTINE.xlsx").Activate
    ActiveWorkbook.Close
    
    'Turn screen updating ON. You won't see the client file being updated.
Application.ScreenUpdating = True

Code 2 which i use for another report. (Faster and shorter)

Sub altfel()
Dim path As String, card As Integer
Dim wbCard As Workbook, wsCard As Worksheet
Dim wbSource As Workbook, wsSource As Worksheet
Dim lr As Long, i As Long, j As Long


Set wbSource = Workbooks("BLOODGROUPCARDENT.xlsm")
Set wsSource = wbSource.Worksheets("SOURCE DATA")

path = "D:\excelreport\BLOODGROUPCARDENT\"
Set wbCard = Workbooks.Open(Filename:=path & "BLOODGROUPCARDENT.xlsx")
Set wsCard = wbCard.Worksheets("BGCARDS")
With wsSource
    lr = .Cells(.Rows.Count, 1).End(xlUp).Row
End With

For i = 2 To lr
    For j = 1 To 28 Step 7
        
        card = card + 1
        wsCard.Cells(6, 3).Offset((card - 1) * 9) = wsSource.Cells(i, j).Offset(, 1)
        wsCard.Cells(7, 3).Offset((card - 1) * 9) = wsSource.Cells(i, j).Offset(, 2)
        wsCard.Cells(6, 7).Offset((card - 1) * 9) = wsSource.Cells(i, j).Offset(, 3)
        wsCard.Cells(7, 7).Offset((card - 1) * 9) = wsSource.Cells(i, j).Offset(, 4)
        wsCard.Cells(8, 4).Offset((card - 1) * 9) = wsSource.Cells(i, j).Offset(, 5)
        wsCard.Cells(9, 3).Offset((card - 1) * 9) = wsSource.Cells(i, j).Offset(, 6)
        
    Next j
    
    wbCard.SaveCopyAs Filename:=path & i - 1 & ".xlsx"
    card = 0
    
Next i
MsgBox "Check the folder!"
Set wbSource = Nothing
Set wsSource = Nothing
Set wbCard = Nothing
Set wsCard = Nothing
End Sub

Code 3.

Sub test()
Dim ws1 As Worksheet, lr As Long, mypath As String, j As Long
ReDim arr(14, 18)
Set ws1 = Sheets("Sheet1")
If Environ("Username") = "leova" Then
    mypath = ThisWorkbook.Path & "\"
    Else
    mypath = "E:\excelreport\AUDIOGRAM\"
End If
lr = ws1.Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For j = 2 To lr
    Sheets("Graf").Copy After:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = j - 1
    Range("B5").Resize(3) = Application.Transpose(Array(ws1.Range("D" & j), ws1.Range("C" & j), ws1.Range("B" & j)))
    Range("G5").Resize(2) = Application.Transpose(Array(ws1.Range("G" & j), ws1.Range("E" & j)))
    Range("J5").Resize(2) = Application.Transpose(Array(ws1.Range("F" & j), ws1.Range("H" & j)))
    Range("M6").Resize(9) = Application.Transpose(Array(ws1.Range("I" & j), ws1.Range("J" & j), ws1.Range("K" & j), ws1.Range("L" & j), _
        ws1.Range("M" & j), ws1.Range("N" & j), ws1.Range("O" & j), ws1.Range("P" & j), ws1.Range("Q" & j)))
    Range("N6").Resize(8) = Application.Transpose(Array(ws1.Range("R" & j), ws1.Range("S" & j), ws1.Range("T" & j), ws1.Range("U" & j), _
        ws1.Range("V" & j), ws1.Range("W" & j), ws1.Range("X" & j), ws1.Range("Y" & j)))
    Range("Q6").Resize(9) = Application.Transpose(Array(ws1.Range("AA" & j), ws1.Range("AB" & j), ws1.Range("AC" & j), ws1.Range("AD" & j), _
        ws1.Range("AE" & j), ws1.Range("AF" & j), ws1.Range("AG" & j), ws1.Range("AH" & j), ws1.Range("AI" & j)))
    Range("R6").Resize(8) = Application.Transpose(Array(ws1.Range("AJ" & j), ws1.Range("AK" & j), ws1.Range("AL" & j), ws1.Range("AM" & j), _
        ws1.Range("AN" & j), ws1.Range("AO" & j), ws1.Range("AP" & j), ws1.Range("AQ" & j)))
    Range("C44").Resize(5) = Application.Transpose(Array(ws1.Range("AR" & j), "", ws1.Range("Z" & j), "", ws1.Range("AT" & j)))
    Range("C9") = ws1.Range("AS" & j)
    With ActiveSheet
        .Move
    End With
    ActiveWorkbook.SaveAs mypath & j - 1 & ".xlsx"
    ActiveWorkbook.Close
Next
Application.DisplayAlerts = True
End Sub

All of the above codes do the same job. I don't know how to set the references for my new attached workbook.
Can anyone help me write codes for attached book?

Thank you.

For Selected Row, so only 1 new file

Sub Selected_Row()
Dim ws1 As Worksheet, ws2 As Worksheet, x As Integer, myfile As String, mypath As String
Set ws1 = Sheets("Master")
x = ActiveCell.Row
myfile = ws1.Range("A" & x) & ".xlsx"
If Environ("Username") = "leova" Then
    mypath = ThisWorkbook.Path & "\"
    Else
    mypath = "D:\excelreport\BLOODGROUPCARDENT\"
End If
Application.ScreenUpdating = False
Sheets("CLINICAL").Copy after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = ws1.Range("D" & x)
Set ws2 = Sheets(ws1.Range("D" & x).Value)
ws2.Range("B5").Resize(4).Value = Application.Transpose(Array(ws1.Range("BF" & x), ws1.Range("D" & x), ws1.Range("E" & x), ws1.Range("C" & x)))
ws2.Range("B11").Resize(5).Value = Application.Transpose(Array(ws1.Range("J" & x), ws1.Range("K" & x), ws1.Range("L" & x), ws1.Range("M" & x), ws1.Range("BG" & x)))
ws2.Range("B17").Resize(3).Value = Application.Transpose(Array(ws1.Range("Q" & x), ws1.Range("R" & x), ws1.Range("S" & x)))
ws2.Range("B22").Resize(3).Value = Application.Transpose(Array(ws1.Range("X" & x), ws1.Range("Y" & x), ws1.Range("BL" & x)))
ws2.Range("B38").Resize(2).Value = Application.Transpose(Array(ws1.Range("AG" & x), ws1.Range("AH" & x)))
ws2.Range("B41").Resize(9).Value = Application.Transpose(Array(ws1.Range("AI" & x), ws1.Range("AM" & x), ws1.Range("AO" & x), ws1.Range("AP" & x), ws1.Range("AQ" & x), _
    ws1.Range("BM" & x), ws1.Range("BN" & x), ws1.Range("BO" & x), ws1.Range("BP" & x)))
ws2.Range("B52").Value = ws1.Range("BD" & x)
ws2.Range("C26").Value = ws1.Range("AC" & x): ws2.Range("C28").Value = ws1.Range("AD" & x)
ws2.Range("C30").Value = ws1.Range("AE" & x): ws2.Range("C32").Value = ws1.Range("AF" & x)
ws2.Range("C41").Value = ws1.Range("AJ" & x)
ws2.Range("D7").Value = ws1.Range("G" & x)
ws2.Range("D22").Resize(2).Value = Application.Transpose(Array(ws1.Range("Z" & x), ws1.Range("AA" & x)))
ws2.Range("D41").Resize(2).Value = Application.Transpose(Array(ws1.Range("AK" & x), ws1.Range("AN" & x)))
ws2.Range("E17").Resize(3).Value = Application.Transpose(Array(ws1.Range("T" & x), ws1.Range("U" & x), ws1.Range("BJ" & x)))
ws2.Range("E41").Value = ws1.Range("AL" & x)
ws2.Range("F7").Resize(2).Value = Application.Transpose(Array(ws1.Range("H" & x), ws1.Range("B" & x)))
ws2.Range("F15").Value = ws1.Range("BH" & x)
ws2.Range("G38").Resize(7).Value = Application.Transpose(ws1.Range("AR" & x).Resize(, 7))
ws2.Range("H23").Value = ws1.Range("AB" & x)
ws2.Range("I5") = ws1.Range("BE" & x): ws2.Range("I11").Value = ws1.Range("N" & x): ws2.Range("I15").Value = ws1.Range("BI" & x)
ws2.Range("I7").Resize(2).Value = Application.Transpose(Array(ws1.Range("I" & x), ws1.Range("F" & x)))
ws2.Range("I17").Resize(3).Value = Application.Transpose(Array(ws1.Range("V" & x), ws1.Range("W" & x), ws1.Range("BK" & x)))
ws2.Range("I38").Resize(5).Value = Application.Transpose(ws1.Range("AY" & x).Resize(, 5))
ws2.Range("I43").Resize(2).Value = Application.Transpose(ws1.Range("BQ" & x).Resize(, 2))
ws2.Range("J12").Resize(2).Value = Application.Transpose(ws1.Range("O" & x).Resize(, 2))
ws2.Move
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs mypath & myfile
ActiveWorkbook.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

For All

Sub All_Rows()
Dim ws1 As Worksheet, ws2 As Worksheet, x As Integer, myfile As String, mypath As String
Set ws1 = Sheets("Master")
If Environ("Username") = "leova" Then
    mypath = ThisWorkbook.Path & "\"
    Else
    mypath = "D:\excelreport\BLOODGROUPCARDENT\"
End If
Application.ScreenUpdating = False
For x = 2 To ws1.Range("A" & Rows.Count).End(xlUp).Row
    myfile = ws1.Range("A" & x) & ".xlsx"
    Sheets("CLINICAL").Copy after:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = ws1.Range("D" & x)
    Set ws2 = Sheets(ws1.Range("D" & x).Value)
    ws2.Range("B5").Resize(4).Value = Application.Transpose(Array(ws1.Range("BF" & x), ws1.Range("D" & x), ws1.Range("E" & x), ws1.Range("C" & x)))
    ws2.Range("B11").Resize(5).Value = Application.Transpose(Array(ws1.Range("J" & x), ws1.Range("K" & x), ws1.Range("L" & x), ws1.Range("M" & x), ws1.Range("BG" & x)))
    ws2.Range("B17").Resize(3).Value = Application.Transpose(Array(ws1.Range("Q" & x), ws1.Range("R" & x), ws1.Range("S" & x)))
    ws2.Range("B22").Resize(3).Value = Application.Transpose(Array(ws1.Range("X" & x), ws1.Range("Y" & x), ws1.Range("BL" & x)))
    ws2.Range("B38").Resize(2).Value = Application.Transpose(Array(ws1.Range("AG" & x), ws1.Range("AH" & x)))
    ws2.Range("B41").Resize(9).Value = Application.Transpose(Array(ws1.Range("AI" & x), ws1.Range("AM" & x), ws1.Range("AO" & x), ws1.Range("AP" & x), ws1.Range("AQ" & x), _
        ws1.Range("BM" & x), ws1.Range("BN" & x), ws1.Range("BO" & x), ws1.Range("BP" & x)))
    ws2.Range("B52").Value = ws1.Range("BD" & x)
    ws2.Range("C26").Value = ws1.Range("AC" & x): ws2.Range("C28").Value = ws1.Range("AD" & x)
    ws2.Range("C30").Value = ws1.Range("AE" & x): ws2.Range("C32").Value = ws1.Range("AF" & x)
    ws2.Range("C41").Value = ws1.Range("AJ" & x)
    ws2.Range("D7").Value = ws1.Range("G" & x)
    ws2.Range("D22").Resize(2).Value = Application.Transpose(Array(ws1.Range("Z" & x), ws1.Range("AA" & x)))
    ws2.Range("D41").Resize(2).Value = Application.Transpose(Array(ws1.Range("AK" & x), ws1.Range("AN" & x)))
    ws2.Range("E17").Resize(3).Value = Application.Transpose(Array(ws1.Range("T" & x), ws1.Range("U" & x), ws1.Range("BJ" & x)))
    ws2.Range("E41").Value = ws1.Range("AL" & x)
    ws2.Range("F7").Resize(2).Value = Application.Transpose(Array(ws1.Range("H" & x), ws1.Range("B" & x)))
    ws2.Range("F15").Value = ws1.Range("BH" & x)
    ws2.Range("G38").Resize(7).Value = Application.Transpose(ws1.Range("AR" & x).Resize(, 7))
    ws2.Range("H23").Value = ws1.Range("AB" & x)
    ws2.Range("I5") = ws1.Range("BE" & x): ws2.Range("I11").Value = ws1.Range("N" & x): ws2.Range("I15").Value = ws1.Range("BI" & x)
    ws2.Range("I7").Resize(2).Value = Application.Transpose(Array(ws1.Range("I" & x), ws1.Range("F" & x)))
    ws2.Range("I17").Resize(3).Value = Application.Transpose(Array(ws1.Range("V" & x), ws1.Range("W" & x), ws1.Range("BK" & x)))
    ws2.Range("I38").Resize(5).Value = Application.Transpose(ws1.Range("AY" & x).Resize(, 5))
    ws2.Range("I43").Resize(2).Value = Application.Transpose(ws1.Range("BQ" & x).Resize(, 2))
    ws2.Range("J12").Resize(2).Value = Application.Transpose(ws1.Range("O" & x).Resize(, 2))
    ws2.Move
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs mypath & myfile
    ActiveWorkbook.Close
    Application.DisplayAlerts = True
Next
Application.ScreenUpdating = True
End Sub

Kind regards
Leo

Thanks Leo,

Does'nt run. Debug gives error at - Sheets(Sheets.Count).Name = ws1.Range("D" & x)

I have attached the file.

It does run

remove data after row 10


Cheers
Leo