Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.misc
|
|||
|
|||
FAO VBA Code MVP's!
Hello,
I found and borrowed this macro from Dave Peterson. It works, but i need to add in a couple of things to make my life that one bit easier. I need to run this over a number of sheets so need the code to do that, and call the new sheets "Sheet Name" Reform. Also, I have a date in B2 (that chages as you go down the rows) that has to go next to each of the indivdual time in the column. So i need ; B C D E......AA 14-Oct 01:23 06:21 06:58 To turn into (in a new sheet) A B 14-Oct 01:23 14-Oct 06:21 14-Oct 06:58 This code puts the times in the order i need but just in column A, and i need to include the dates. I need some VBA hlep. Thanks in advance Sub rowstocol() Dim wks As Worksheet Dim colnos As Long Dim CopytoSheet As Worksheet If ActiveSheet.Name = "A2" Then MsgBox "Active Sheet Not Valid" & Chr(13) _ & "Try Another Worksheet." Exit Sub Else Set wks = ActiveSheet Application.ScreenUpdating = False For Each Wksht In Worksheets With Wksht If .Name = "A2" Then Application.DisplayAlerts = False Sheets("A2").Delete End If End With Next Application.DisplayAlerts = True Set CopytoSheet = Worksheets.Add CopytoSheet.Name = "A2" wks.Activate Range("C1").Select colnos = InputBox("Enter Number of Columns to Transpose to Rows") Do Until ActiveCell.Value = "" ActiveCell.Offset(1, 0).Select With ActiveCell .Resize(1, colnos).Copy End With Sheets("A2").Select Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, _ SkipBlanks:=False _ , Transpose:=True Application.CutCopyMode = False ActiveSheet.Cells(Rows.Count, ActiveCell.Column).End(xlUp).Select ActiveCell.Offset(1, 0).Select 'note: changed from 2 to 1 ' Selection.EntireRow.Insert 'note: I have remmed out this line wks.Activate ActiveCell.Select Loop Sheets("A2").Activate End If End Sub |
#2
Posted to microsoft.public.excel.misc
|
|||
|
|||
FAO VBA Code MVP's!
I'm not sure I understand, but maybe...
I'm not sure what worksheets should be used, so you should group the ones you want first. Click on the first tab and ctrl-click on subsequent. (Remember to ungroup when you're done!) This code loops through row 2 through the bottom of column A. Then it copies|transposes the dates/times into a giant combined single sheet (named Reform). Option Explicit Sub rowstocol2() Dim mySelectedSheets As Object Dim resp As Long Dim wks As Worksheet Dim NewWks As Worksheet Dim RngToCopy As Range Dim iRow As Long Dim oRow As Long Set mySelectedSheets = ActiveWindow.SelectedSheets If mySelectedSheets.Count = 1 Then resp = MsgBox(prompt:="You only selected one sheet!", _ Buttons:=vbOKCancel) If resp = vbCancel Then Exit Sub End If End If On Error Resume Next Application.DisplayAlerts = False Worksheets("Reform").Delete Application.DisplayAlerts = True On Error GoTo 0 Set NewWks = Worksheets.Add With NewWks .Name = "Reform" .Range("a1:B1").Value = Array("date", "time") .Range("a1").EntireColumn.NumberFormat = "mm/dd/yyyy" .Range("B1").EntireColumn.NumberFormat = "hh:mm:ss" End With oRow = 2 For Each wks In mySelectedSheets With wks For iRow = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row Set RngToCopy = .Range(.Cells(iRow, "B"), _ .Cells(iRow, .Columns.Count).End(xlToLeft)) If Application.CountA(RngToCopy) = 0 Then 'nothing to copy, skip it Else NewWks.Cells(oRow, "A") _ .Resize(RngToCopy.Cells.Count, 1).Value _ = .Cells(iRow, "A").Value RngToCopy.Copy NewWks.Cells(oRow, "B").PasteSpecial Transpose:=True oRow = oRow + RngToCopy.Cells.Count End If Next iRow End With Next wks NewWks.UsedRange.Columns.AutoFit Application.CutCopyMode = False End Sub Buyone wrote: Hello, I found and borrowed this macro from Dave Peterson. It works, but i need to add in a couple of things to make my life that one bit easier. I need to run this over a number of sheets so need the code to do that, and call the new sheets "Sheet Name" Reform. Also, I have a date in B2 (that chages as you go down the rows) that has to go next to each of the indivdual time in the column. So i need ; B C D E......AA 14-Oct 01:23 06:21 06:58 To turn into (in a new sheet) A B 14-Oct 01:23 14-Oct 06:21 14-Oct 06:58 This code puts the times in the order i need but just in column A, and i need to include the dates. I need some VBA hlep. Thanks in advance Sub rowstocol() Dim wks As Worksheet Dim colnos As Long Dim CopytoSheet As Worksheet If ActiveSheet.Name = "A2" Then MsgBox "Active Sheet Not Valid" & Chr(13) _ & "Try Another Worksheet." Exit Sub Else Set wks = ActiveSheet Application.ScreenUpdating = False For Each Wksht In Worksheets With Wksht If .Name = "A2" Then Application.DisplayAlerts = False Sheets("A2").Delete End If End With Next Application.DisplayAlerts = True Set CopytoSheet = Worksheets.Add CopytoSheet.Name = "A2" wks.Activate Range("C1").Select colnos = InputBox("Enter Number of Columns to Transpose to Rows") Do Until ActiveCell.Value = "" ActiveCell.Offset(1, 0).Select With ActiveCell .Resize(1, colnos).Copy End With Sheets("A2").Select Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, _ SkipBlanks:=False _ , Transpose:=True Application.CutCopyMode = False ActiveSheet.Cells(Rows.Count, ActiveCell.Column).End(xlUp).Select ActiveCell.Offset(1, 0).Select 'note: changed from 2 to 1 ' Selection.EntireRow.Insert 'note: I have remmed out this line wks.Activate ActiveCell.Select Loop Sheets("A2").Activate End If End Sub -- Dave Peterson |
#3
Posted to microsoft.public.excel.misc
|
|||
|
|||
FAO VBA Code MVP's!
Hi Dave,
Thanks very much. That works a treat. Apologies for my poor description, but is there a way of creating seperate "reform" sheets for each sheet it goes through? So Sheet 1 has a new sheet called "Sheet 1 Reform"? Again thank you for your help. "Dave Peterson" wrote: I'm not sure I understand, but maybe... I'm not sure what worksheets should be used, so you should group the ones you want first. Click on the first tab and ctrl-click on subsequent. (Remember to ungroup when you're done!) This code loops through row 2 through the bottom of column A. Then it copies|transposes the dates/times into a giant combined single sheet (named Reform). Option Explicit Sub rowstocol2() Dim mySelectedSheets As Object Dim resp As Long Dim wks As Worksheet Dim NewWks As Worksheet Dim RngToCopy As Range Dim iRow As Long Dim oRow As Long Set mySelectedSheets = ActiveWindow.SelectedSheets If mySelectedSheets.Count = 1 Then resp = MsgBox(prompt:="You only selected one sheet!", _ Buttons:=vbOKCancel) If resp = vbCancel Then Exit Sub End If End If On Error Resume Next Application.DisplayAlerts = False Worksheets("Reform").Delete Application.DisplayAlerts = True On Error GoTo 0 Set NewWks = Worksheets.Add With NewWks .Name = "Reform" .Range("a1:B1").Value = Array("date", "time") .Range("a1").EntireColumn.NumberFormat = "mm/dd/yyyy" .Range("B1").EntireColumn.NumberFormat = "hh:mm:ss" End With oRow = 2 For Each wks In mySelectedSheets With wks For iRow = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row Set RngToCopy = .Range(.Cells(iRow, "B"), _ .Cells(iRow, .Columns.Count).End(xlToLeft)) If Application.CountA(RngToCopy) = 0 Then 'nothing to copy, skip it Else NewWks.Cells(oRow, "A") _ .Resize(RngToCopy.Cells.Count, 1).Value _ = .Cells(iRow, "A").Value RngToCopy.Copy NewWks.Cells(oRow, "B").PasteSpecial Transpose:=True oRow = oRow + RngToCopy.Cells.Count End If Next iRow End With Next wks NewWks.UsedRange.Columns.AutoFit Application.CutCopyMode = False End Sub Buyone wrote: Hello, I found and borrowed this macro from Dave Peterson. It works, but i need to add in a couple of things to make my life that one bit easier. I need to run this over a number of sheets so need the code to do that, and call the new sheets "Sheet Name" Reform. Also, I have a date in B2 (that chages as you go down the rows) that has to go next to each of the indivdual time in the column. So i need ; B C D E......AA 14-Oct 01:23 06:21 06:58 To turn into (in a new sheet) A B 14-Oct 01:23 14-Oct 06:21 14-Oct 06:58 This code puts the times in the order i need but just in column A, and i need to include the dates. I need some VBA hlep. Thanks in advance Sub rowstocol() Dim wks As Worksheet Dim colnos As Long Dim CopytoSheet As Worksheet If ActiveSheet.Name = "A2" Then MsgBox "Active Sheet Not Valid" & Chr(13) _ & "Try Another Worksheet." Exit Sub Else Set wks = ActiveSheet Application.ScreenUpdating = False For Each Wksht In Worksheets With Wksht If .Name = "A2" Then Application.DisplayAlerts = False Sheets("A2").Delete End If End With Next Application.DisplayAlerts = True Set CopytoSheet = Worksheets.Add CopytoSheet.Name = "A2" wks.Activate Range("C1").Select colnos = InputBox("Enter Number of Columns to Transpose to Rows") Do Until ActiveCell.Value = "" ActiveCell.Offset(1, 0).Select With ActiveCell .Resize(1, colnos).Copy End With Sheets("A2").Select Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, _ SkipBlanks:=False _ , Transpose:=True Application.CutCopyMode = False ActiveSheet.Cells(Rows.Count, ActiveCell.Column).End(xlUp).Select ActiveCell.Offset(1, 0).Select 'note: changed from 2 to 1 ' Selection.EntireRow.Insert 'note: I have remmed out this line wks.Activate ActiveCell.Select Loop Sheets("A2").Activate End If End Sub -- Dave Peterson . |
#4
Posted to microsoft.public.excel.misc
|
|||
|
|||
FAO VBA Code MVP's!
Try:
Option Explicit Sub rowstocol2() Dim mySelectedSheets As Object Dim resp As Long Dim wks As Worksheet Dim NewWks As Worksheet Dim RngToCopy As Range Dim iRow As Long Dim oRow As Long Set mySelectedSheets = ActiveWindow.SelectedSheets If mySelectedSheets.Count = 1 Then resp = MsgBox(prompt:="You only selected one sheet!", _ Buttons:=vbOKCancel) If resp = vbCancel Then Exit Sub End If End If oRow = 2 For Each wks In mySelectedSheets With wks On Error Resume Next Application.DisplayAlerts = False Worksheets(.Name & " Reform").Delete Application.DisplayAlerts = True On Error GoTo 0 Set NewWks = Worksheets.Add With NewWks On Error Resume Next .Name = wks.Name & " Reform" If Err.Number < 0 Then Err.Clear MsgBox "Rename failed for: " & .Name End If On Error GoTo 0 .Range("a1:B1").Value = Array("date", "time") .Range("a1").EntireColumn.NumberFormat = "mm/dd/yyyy" .Range("B1").EntireColumn.NumberFormat = "hh:mm:ss" End With For iRow = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row Set RngToCopy = .Range(.Cells(iRow, "B"), _ .Cells(iRow, .Columns.Count).End(xlToLeft)) If Application.CountA(RngToCopy) = 0 Then 'nothing to copy, skip it Else NewWks.Cells(oRow, "A") _ .Resize(RngToCopy.Cells.Count, 1).Value _ = .Cells(iRow, "A").Value RngToCopy.Copy NewWks.Cells(oRow, "B").PasteSpecial Transpose:=True oRow = oRow + RngToCopy.Cells.Count End If Next iRow End With Next wks NewWks.UsedRange.Columns.AutoFit Application.CutCopyMode = False End Sub Buyone wrote: Hi Dave, Thanks very much. That works a treat. Apologies for my poor description, but is there a way of creating seperate "reform" sheets for each sheet it goes through? So Sheet 1 has a new sheet called "Sheet 1 Reform"? Again thank you for your help. "Dave Peterson" wrote: I'm not sure I understand, but maybe... I'm not sure what worksheets should be used, so you should group the ones you want first. Click on the first tab and ctrl-click on subsequent. (Remember to ungroup when you're done!) This code loops through row 2 through the bottom of column A. Then it copies|transposes the dates/times into a giant combined single sheet (named Reform). Option Explicit Sub rowstocol2() Dim mySelectedSheets As Object Dim resp As Long Dim wks As Worksheet Dim NewWks As Worksheet Dim RngToCopy As Range Dim iRow As Long Dim oRow As Long Set mySelectedSheets = ActiveWindow.SelectedSheets If mySelectedSheets.Count = 1 Then resp = MsgBox(prompt:="You only selected one sheet!", _ Buttons:=vbOKCancel) If resp = vbCancel Then Exit Sub End If End If On Error Resume Next Application.DisplayAlerts = False Worksheets("Reform").Delete Application.DisplayAlerts = True On Error GoTo 0 Set NewWks = Worksheets.Add With NewWks .Name = "Reform" .Range("a1:B1").Value = Array("date", "time") .Range("a1").EntireColumn.NumberFormat = "mm/dd/yyyy" .Range("B1").EntireColumn.NumberFormat = "hh:mm:ss" End With oRow = 2 For Each wks In mySelectedSheets With wks For iRow = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row Set RngToCopy = .Range(.Cells(iRow, "B"), _ .Cells(iRow, .Columns.Count).End(xlToLeft)) If Application.CountA(RngToCopy) = 0 Then 'nothing to copy, skip it Else NewWks.Cells(oRow, "A") _ .Resize(RngToCopy.Cells.Count, 1).Value _ = .Cells(iRow, "A").Value RngToCopy.Copy NewWks.Cells(oRow, "B").PasteSpecial Transpose:=True oRow = oRow + RngToCopy.Cells.Count End If Next iRow End With Next wks NewWks.UsedRange.Columns.AutoFit Application.CutCopyMode = False End Sub Buyone wrote: Hello, I found and borrowed this macro from Dave Peterson. It works, but i need to add in a couple of things to make my life that one bit easier. I need to run this over a number of sheets so need the code to do that, and call the new sheets "Sheet Name" Reform. Also, I have a date in B2 (that chages as you go down the rows) that has to go next to each of the indivdual time in the column. So i need ; B C D E......AA 14-Oct 01:23 06:21 06:58 To turn into (in a new sheet) A B 14-Oct 01:23 14-Oct 06:21 14-Oct 06:58 This code puts the times in the order i need but just in column A, and i need to include the dates. I need some VBA hlep. Thanks in advance Sub rowstocol() Dim wks As Worksheet Dim colnos As Long Dim CopytoSheet As Worksheet If ActiveSheet.Name = "A2" Then MsgBox "Active Sheet Not Valid" & Chr(13) _ & "Try Another Worksheet." Exit Sub Else Set wks = ActiveSheet Application.ScreenUpdating = False For Each Wksht In Worksheets With Wksht If .Name = "A2" Then Application.DisplayAlerts = False Sheets("A2").Delete End If End With Next Application.DisplayAlerts = True Set CopytoSheet = Worksheets.Add CopytoSheet.Name = "A2" wks.Activate Range("C1").Select colnos = InputBox("Enter Number of Columns to Transpose to Rows") Do Until ActiveCell.Value = "" ActiveCell.Offset(1, 0).Select With ActiveCell .Resize(1, colnos).Copy End With Sheets("A2").Select Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, _ SkipBlanks:=False _ , Transpose:=True Application.CutCopyMode = False ActiveSheet.Cells(Rows.Count, ActiveCell.Column).End(xlUp).Select ActiveCell.Offset(1, 0).Select 'note: changed from 2 to 1 ' Selection.EntireRow.Insert 'note: I have remmed out this line wks.Activate ActiveCell.Select Loop Sheets("A2").Activate End If End Sub -- Dave Peterson . -- Dave Peterson |
#5
Posted to microsoft.public.excel.misc
|
|||
|
|||
FAO VBA Code MVP's!
Hi Dave,
After a little tweaking that's working perfectly for me. Thanks for your help. It's appreciated "Dave Peterson" wrote: Try: Option Explicit Sub rowstocol2() Dim mySelectedSheets As Object Dim resp As Long Dim wks As Worksheet Dim NewWks As Worksheet Dim RngToCopy As Range Dim iRow As Long Dim oRow As Long Set mySelectedSheets = ActiveWindow.SelectedSheets If mySelectedSheets.Count = 1 Then resp = MsgBox(prompt:="You only selected one sheet!", _ Buttons:=vbOKCancel) If resp = vbCancel Then Exit Sub End If End If oRow = 2 For Each wks In mySelectedSheets With wks On Error Resume Next Application.DisplayAlerts = False Worksheets(.Name & " Reform").Delete Application.DisplayAlerts = True On Error GoTo 0 Set NewWks = Worksheets.Add With NewWks On Error Resume Next .Name = wks.Name & " Reform" If Err.Number < 0 Then Err.Clear MsgBox "Rename failed for: " & .Name End If On Error GoTo 0 .Range("a1:B1").Value = Array("date", "time") .Range("a1").EntireColumn.NumberFormat = "mm/dd/yyyy" .Range("B1").EntireColumn.NumberFormat = "hh:mm:ss" End With For iRow = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row Set RngToCopy = .Range(.Cells(iRow, "B"), _ .Cells(iRow, .Columns.Count).End(xlToLeft)) If Application.CountA(RngToCopy) = 0 Then 'nothing to copy, skip it Else NewWks.Cells(oRow, "A") _ .Resize(RngToCopy.Cells.Count, 1).Value _ = .Cells(iRow, "A").Value RngToCopy.Copy NewWks.Cells(oRow, "B").PasteSpecial Transpose:=True oRow = oRow + RngToCopy.Cells.Count End If Next iRow End With Next wks NewWks.UsedRange.Columns.AutoFit Application.CutCopyMode = False End Sub Buyone wrote: Hi Dave, Thanks very much. That works a treat. Apologies for my poor description, but is there a way of creating seperate "reform" sheets for each sheet it goes through? So Sheet 1 has a new sheet called "Sheet 1 Reform"? Again thank you for your help. "Dave Peterson" wrote: I'm not sure I understand, but maybe... I'm not sure what worksheets should be used, so you should group the ones you want first. Click on the first tab and ctrl-click on subsequent. (Remember to ungroup when you're done!) This code loops through row 2 through the bottom of column A. Then it copies|transposes the dates/times into a giant combined single sheet (named Reform). Option Explicit Sub rowstocol2() Dim mySelectedSheets As Object Dim resp As Long Dim wks As Worksheet Dim NewWks As Worksheet Dim RngToCopy As Range Dim iRow As Long Dim oRow As Long Set mySelectedSheets = ActiveWindow.SelectedSheets If mySelectedSheets.Count = 1 Then resp = MsgBox(prompt:="You only selected one sheet!", _ Buttons:=vbOKCancel) If resp = vbCancel Then Exit Sub End If End If On Error Resume Next Application.DisplayAlerts = False Worksheets("Reform").Delete Application.DisplayAlerts = True On Error GoTo 0 Set NewWks = Worksheets.Add With NewWks .Name = "Reform" .Range("a1:B1").Value = Array("date", "time") .Range("a1").EntireColumn.NumberFormat = "mm/dd/yyyy" .Range("B1").EntireColumn.NumberFormat = "hh:mm:ss" End With oRow = 2 For Each wks In mySelectedSheets With wks For iRow = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row Set RngToCopy = .Range(.Cells(iRow, "B"), _ .Cells(iRow, .Columns.Count).End(xlToLeft)) If Application.CountA(RngToCopy) = 0 Then 'nothing to copy, skip it Else NewWks.Cells(oRow, "A") _ .Resize(RngToCopy.Cells.Count, 1).Value _ = .Cells(iRow, "A").Value RngToCopy.Copy NewWks.Cells(oRow, "B").PasteSpecial Transpose:=True oRow = oRow + RngToCopy.Cells.Count End If Next iRow End With Next wks NewWks.UsedRange.Columns.AutoFit Application.CutCopyMode = False End Sub Buyone wrote: Hello, I found and borrowed this macro from Dave Peterson. It works, but i need to add in a couple of things to make my life that one bit easier. I need to run this over a number of sheets so need the code to do that, and call the new sheets "Sheet Name" Reform. Also, I have a date in B2 (that chages as you go down the rows) that has to go next to each of the indivdual time in the column. So i need ; B C D E......AA 14-Oct 01:23 06:21 06:58 To turn into (in a new sheet) A B 14-Oct 01:23 14-Oct 06:21 14-Oct 06:58 This code puts the times in the order i need but just in column A, and i need to include the dates. I need some VBA hlep. Thanks in advance Sub rowstocol() Dim wks As Worksheet Dim colnos As Long Dim CopytoSheet As Worksheet If ActiveSheet.Name = "A2" Then MsgBox "Active Sheet Not Valid" & Chr(13) _ & "Try Another Worksheet." Exit Sub Else Set wks = ActiveSheet Application.ScreenUpdating = False For Each Wksht In Worksheets With Wksht If .Name = "A2" Then Application.DisplayAlerts = False Sheets("A2").Delete End If End With Next Application.DisplayAlerts = True Set CopytoSheet = Worksheets.Add CopytoSheet.Name = "A2" wks.Activate Range("C1").Select colnos = InputBox("Enter Number of Columns to Transpose to Rows") Do Until ActiveCell.Value = "" ActiveCell.Offset(1, 0).Select With ActiveCell .Resize(1, colnos).Copy End With Sheets("A2").Select Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, _ SkipBlanks:=False _ , Transpose:=True Application.CutCopyMode = False ActiveSheet.Cells(Rows.Count, ActiveCell.Column).End(xlUp).Select ActiveCell.Offset(1, 0).Select 'note: changed from 2 to 1 ' Selection.EntireRow.Insert 'note: I have remmed out this line wks.Activate ActiveCell.Select Loop Sheets("A2").Activate End If End Sub -- Dave Peterson . -- Dave Peterson . |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
to the MVP's: a Big Thank You | Excel Discussion (Misc queries) | |||
MVP's | Excel Discussion (Misc queries) | |||
MVP's, please help me understand SUMPRODUCT. | New Users to Excel | |||
All MVP's, Try this one | Excel Discussion (Misc queries) | |||
MVP's | Excel Discussion (Misc queries) |