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 = "D:\excelreport\BLOODGROUPCARDENT\"
End If
lr = ws1.Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For j = 2 To lr
arr(0, 0) = Sheets("Graf").Range("A1")
arr(2, 11) = "RIGHT EAR": arr(2, 15) = "LEFT EAR"
arr(3, 0) = Sheets("Graf").Range("A4"): arr(3, 11) = "FREQUENCY": arr(3, 12) = "dB Air": arr(3, 13) = "dB Bone": arr(3, 15) = "FREQUENCY": arr(3, 16) = "dB Air": arr(3, 17) = "dB Bone"
arr(5, 0) = "NAME:": arr(5, 1) = ws1.Range("D" & j): arr(5, 4) = "***:": arr(5, 5) = ws1.Range("G" & j): arr(5, 8) = "AGE:": arr(5, 9) = ws1.Range("F" & j)
arr(5, 11) = "250": arr(5, 12) = ws1.Range("I" & j): arr(5, 13) = ws1.Range("R" & j): arr(5, 15) = "250": arr(5, 16) = ws1.Range("AA" & j): arr(5, 17) = ws1.Range("AJ" & j)
arr(6, 0) = "EMP NO:": arr(6, 1) = ws1.Range("C" & j): arr(6, 4) = "DEPT:": arr(6, 5) = ws1.Range("E" & j): arr(6, 8) = "DATE:": arr(6, 9) = ws1.Range("H" & j)
arr(6, 11) = "500": arr(6, 12) = ws1.Range("J" & j): arr(6, 13) = ws1.Range("S" & j): arr(6, 15) = "500": arr(6, 16) = ws1.Range("AB" & j): arr(6, 17) = ws1.Range("AK" & j)
arr(7, 0) = "Ref By:": arr(7, 1) = ws1.Range("B" & j): arr(7, 11) = "1K": arr(7, 12) = ws1.Range("K" & j): arr(7, 13) = ws1.Range("T" & j)
arr(7, 15) = "1K": arr(7, 16) = ws1.Range("AC" & j): arr(7, 17) = ws1.Range("AL" & j)
arr(8, 0) = Sheets("Graf").Range("A9"): arr(8, 5) = Sheets("Graf").Range("F9"): arr(8, 11) = "1.5K": arr(8, 12) = ws1.Range("L" & j): arr(8, 13) = ws1.Range("U" & j): arr(8, 15) = "1.5K": arr(8, 16) = ws1.Range("AD" & j): arr(8, 17) = ws1.Range("AM" & j)
arr(9, 11) = "2K": arr(9, 12) = ws1.Range("M" & j): arr(9, 13) = ws1.Range("V" & j): arr(9, 15) = "2K": arr(9, 16) = ws1.Range("AE" & j): arr(9, 17) = ws1.Range("AN" & j)
arr(10, 11) = "3K": arr(10, 12) = ws1.Range("N" & j): arr(10, 13) = ws1.Range("W" & j): arr(10, 15) = "3K": arr(10, 16) = ws1.Range("AF" & j): arr(10, 17) = ws1.Range("AO" & j)
arr(11, 11) = "4K": arr(11, 12) = ws1.Range("O" & j): arr(11, 13) = ws1.Range("X" & j): arr(11, 15) = "4K": arr(11, 16) = ws1.Range("AG" & j): arr(11, 17) = ws1.Range("AP" & j)
arr(12, 11) = "6K": arr(12, 12) = ws1.Range("P" & j): arr(12, 13) = ws1.Range("Y" & j): arr(12, 15) = "6K": arr(12, 16) = ws1.Range("AH" & j): arr(12, 17) = ws1.Range("AQ" & j)
arr(13, 11) = "8K": arr(13, 12) = ws1.Range("Q" & j): arr(13, 15) = "8K": arr(13, 16) = ws1.Range("AI" & j)
Sheets("Graf").Copy After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = j - 1
With ActiveSheet
.Range("A1").Resize(14, 18) = arr
.Move
End With
ActiveWorkbook.SaveAs mypath & j - 1 & ".xlsx"
ActiveWorkbook.Close
Next
End Sub
Kind regards
Bookmarks