select columns to create new workbook

[winnie123]

I have a spreadsheet with columns A - N populated, at the moment there are 89
rows of data text and numeric. The number of rows can change if new items are
added.

I would like to be able to select Col A and then another column of the users
choice, copy the data to a new worksheet, keeping the original format. so eg
col A and Col F need to be copied into new w/b in Col A and Col B. Even
better if I could use the heading from Col B to Col N for the user to select
instead of Col F

I would then like the user ID, date and time to be entered into C1, the name
of a customer in C2 ( could this be entered via an input box) and then the
command file save as appear, so that the user can save the file.

Any ideas?

Thanks

Winnie

 

[Per Jessen]

Hi Winnie

In cell P2 I created a validation list holding the Column Headings (Data >
Validation > Allow: List > Source: =B1:N1) > OK), and then I inserted a
CommandButton to call the macro "CopySelectedColumns"


Private Declare Function apiGetUserName Lib "advapi32.dll" Alias _
"GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Sub CopySelectedColumns()
Dim wbA As Workbook
Dim CopyToWb As Workbook
Set wbA = ThisWorkbook
SelectedCol = Range("P2").Value
fCol = Range("B1:N1").Find(what:=SelectedCol, _
Lookat:=xlWhole).Column

Set CopyToWb = Workbooks.Add
wbA.Worksheets("Sheet1").Columns(1).Copy _
CopyToWb.Worksheets("Sheet1").Range("A1")
wbA.Worksheets("Sheet1").Columns(fCol).Copy _
CopyToWb.Worksheets("Sheet1").Range("B1")
CopyToWb.Worksheets("Sheet1").Range("C1") = _
fOSUserName & ", " & Now()

Do
Customer = InputBox("Enter customer name", "Regargs, PJ")
Loop Until Customer <> ""
CopyToWb.Worksheets("Sheet1").Range("C2") = Customer

Do
SaveAsFileName = Application.GetSaveAsFilename _
(fileFilter:="Excel Files (*.xls), *.xls")
Loop Until SaveAsFileName <> False

CopyToWb.SaveAs Filename:=SaveAsFileName
CopyToWb.Close 'Remove this line if the new workbook shall remain open
End Sub

Function fOSUserName() As String
' Returns the network login name
Dim lngLen As Long, lngX As Long
Dim strUserName As String
strUserName = String$(254, 0)
lngLen = 255
lngX = apiGetUserName(strUserName, lngLen)
If (lngX > 0) Then
fOSUserName = Left$(strUserName, lngLen - 1)
Else
fOSUserName = vbNullString
End If
End Function


Best regards,
Per

 

[Joel]

Sub Copycolumns()

Set Sourcesht = ActiveSheet
Set Newsht = Sheets.Add(after:=Sheets(Sheets.Count))


Set CopyRange = Application.InputBox(prompt:="Select columns" & vbCrLf & _
"Use Cntl Key to select multiple coluns" & vbCrLf & _
"Don't Select Column A", _
Title:="Select coluns", Type:=8)

'copy column A
With Newsht
Sourcesht.Columns("A").Copy Destination:=.Columns("A")
ColCount = 2
For Each col In CopyRange.Columns
CopyRange.Columns(1).Copy Destination:=.Columns(ColCount)
ColCount = ColCount + 1
Next col

End With

End Sub

 

[Mike H]

Hi,

Try the code below.

Sub Sonic()
Dim MySelection As Range
ttl = "Hold down the CTRL key and select a cell in each column to be copied"
Set MySelection = Application.InputBox(prompt:=ttl, Type:=8)
MySelection.EntireColumn.Copy
Workbooks.Add
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False

uid = InputBox("enter user ID")
Range("C1").Value = uid & Format(Now(), "dd/mm/yyyy hh:mm")
cid = InputBox("enter Customer ID")
Range("C2").Value = cid
Application.GetSaveAsFilename
End Sub

Mike

 

[Mike H]

Hi,

You wanted it in a new worksheet not workbook so change this

Workbooks.Add

to this

Worksheets.Add

Mike

 

[winnie123]

Thanks Per,

this works perfectly.

One more question if I may please.

Columns B to N are numeric (prices) I have added a data validation to select
currency in Q2 and then I use a lookup formula in R2 to get the exchange rate.

Could the exchange rate be used to be able to multiply the column selected.

Eg

original price is £75.00, should end up €90.00 using exchange rate of 1.2


Thanks for your help

Winnie

 

[Per Jessen]

Thanks for your reply,

I assume the exchange rate is in the original sheet. We can use PasteSpecial
for this task.

Sub CopySelectedColumns()
Dim wbA As Workbook
Dim CopyToWb As Workbook
Dim RateCell As Range
Set wbA = ThisWorkbook
SelectedCol = Range("P2").Value
fCol = Range("B1:N1").Find(what:=SelectedCol, _
Lookat:=xlWhole).Column

Set CopyToWb = Workbooks.Add
Set RateCell = wbA.Worksheets("Sheet1").Range("R2")

wbA.Worksheets("Sheet1").Columns(1).Copy _
CopyToWb.Worksheets("Sheet1").Range("A1")
wbA.Worksheets("Sheet1").Columns(fCol).Copy _
CopyToWb.Worksheets("Sheet1").Range("B1")
CopyToWb.Worksheets("Sheet1").Range("C1") = _
fOSUserName & ", " & Now()

Do
Customer = InputBox("Enter customer name", "Regards, PJ")
Loop Until Customer <> ""
CopyToWb.Worksheets("Sheet1").Range("C2") = Customer

LastRow = CopyToWb.Worksheets("Sheet1").Range("B" &
Rows.Count).End(xlUp).Row

RateCell.Copy
CopyToWb.Worksheets("Sheet1").Range("B2:B" & LastRow).PasteSpecial _
Paste:=xlAll, Operation:=xlMultiply, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False

Do
SaveAsFileName = Application.GetSaveAsFilename _
(fileFilter:="Excel Files (*.xls), *.xls")
Loop Until SaveAsFileName <> False

CopyToWb.SaveAs Filename:=SaveAsFileName
CopyToWb.Close 'Remove this line if the new workbook shall remain open
End Sub

Regards,
Per

 

[winnie123]

Hi Per,

Thanks again, but because there is a formula in R2, I am getting value error
in the new w/b. I have tried without the formula and it works. So how can I
get it to look at the value in R2 and not the formula.

Thanks

Winnie

 

[winnie123]

What am I like, feel like a dumbo

just needed paste value instead of All.

Thanks for all your help

 

[Per Jessen]

Hi Winnie,

Thanks for your reply, I am glad that you solved it...

Regards,
Per