FAO VBA Code MVP's!

[Buyone]

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]

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]

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]

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]

Hi Dave,

After a little tweaking that's working perfectly for me.

Thanks for your help. It's appreciated