Don't like ads? PRO users don't see any ads ;-)
Public Pastes
Guest

Untitled

By: a guest on Jul 20th, 2012  |  syntax: None  |  size: 2.15 KB  |  hits: 11  |  expires: Never
download  |  raw  |  embed  |  report abuse  |  print
Text below is selected. Please press Ctrl+C to copy to your clipboard. (⌘+C on Mac)
  1. Sub CreateWbFromNames()
  2.     Dim r As Integer
  3.     Dim p, n, d, f, l, main As String
  4.     Dim wb As Workbook
  5.     Dim ws As Worksheet
  6.     Dim cellSplit As Variant
  7.    
  8.     main = ActiveWorkbook.name
  9.     r = 2
  10.  
  11.     ' start loop
  12.     Do While Range("A" & r).Value <> ""
  13.         p = Range("Q" & r).Text
  14.         d = "0"
  15.         ' check for . in name
  16.         If InStr(p, ".") Then
  17.             cellSplit = Split(p, ".")
  18.             f = cellSplit(0)
  19.             l = cellSplit(1)
  20.             n = f & "_" & l
  21.         Else
  22.             n = p
  23.         End If
  24.         '  check for workbook
  25.         For Each wb In Workbooks
  26.              If wb.name = n & ".xls" Then
  27.                 d = wb.name
  28.                 Exit For
  29.              End If
  30.         Next wb
  31.         ' if wb doesn't exist, create it
  32.         If d = "0" Then
  33.             Workbooks.Add
  34.             ActiveWorkbook.SaveAs n & ".xls"
  35.             d = n & ".xls"
  36.             ' copy and paste the first row
  37.             Workbooks(main).Activate
  38.             Range("A1").EntireRow.Copy
  39.             Workbooks(d).Activate
  40.             Range("A1").Select
  41.             Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
  42.                     False, Transpose:=False
  43.             ActiveWorkbook.Save
  44.         End If
  45.         ' copy the row
  46.              Workbooks(main).Activate
  47.              Range("A" & r).EntireRow.Copy
  48.              Workbooks(d).Activate
  49.          ' check for empty row
  50.               If Range("A1") = "" Then
  51.                  Range("A1").Select
  52.               Else
  53.                  Range("A1000").End(xlUp).Offset(1, 0).Select
  54.               End If
  55.          ' paste data
  56.                Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
  57.                      False, Transpose:=False
  58.                 ActiveWorkbook.Save
  59.           ' increment row
  60.           Workbooks(main).Activate
  61.           r = r + 1
  62.     Loop
  63.     ' close all workbooks but main and personal.xls
  64.     For Each wb In Workbooks
  65.         If wb.name <> main And wb.name <> "PERSONAL.XLS" Then
  66.                 wb.Close
  67.         End If
  68.     Next wb
  69.    
  70.     MsgBox ("Actions Completed")
  71.    
  72. End Sub
create a new version of this paste RAW Paste Data