How can I reverse this offset property? - vba

I have data that I'm moving into a template, and I'm trying to repurpose my vba script I used. Before, the data needed to be transposed into a specific range, but now I want to just move it over without the need to transpose it.
'Write the employee data into the template
a = 0
For k = 2 To UBound(Data, 2)
Dest.Offset(a, j) = Data(i, k)
a = a + 1
Next
I assume the dest.offset property is what is causing the transposition, how would I change this to just move the array normally without the transpose?
Rest of script:
Option Explicit
Sub Main()
Dim Wb As Workbook
Dim Data, Last
Dim i As Long, j As Long, k As Long, a As Long
Dim Dest As Range
'Refer to the template
Set Wb = Workbooks("ValidationTemplate.xlsx")
'Refer to the destination cell
Set Dest = Wb.Sheets("Employee Core Skills").Range("B3")
'Read in all data
With ThisWorkbook.Sheets("Sheet1")
Data = .Range("DO2", .Range("A" & Rows.Count).End(xlUp))
End With
Wb.Activate
Application.ScreenUpdating = False
'Process the data
For i = 1 To UBound(Data)
'Manager changes?
If Data(i, 1) <> Last Then
'Skip the first
If i > 1 Then
'Scroll into the view
Dest.Select
'Save a copy
Wb.SaveCopyAs ThisWorkbook.Path & Application.PathSeparator & _
ValidFileName(Last & "_Assessment.xlsx")
End If
'Clear the employees
Dest.Resize(, Columns.Count - Dest.Column).EntireColumn.ClearContents
'Remember this manager
Last = Data(i, 1)
'Start the next round
j = 0
End If
'Write the employee data into the template
a = 0
For k = 2 To UBound(Data, 2)
Dest.Offset(a, j) = Data(i, k)
a = a + 1
Next
End If
'Next column
j = j + 1
Next
End Sub

If I understand your question correctly...
Dest.Offset(a, j)
Means use the Range referred to by the Range Object called Dest, then offset from there a rows (positive would be down the spreadsheet, negative up the spreadsheet) and j columns (positive to the right, negative to the left).
If you just want to put the data in the Range pointed to by Dest, then simply omit the .Offset() portion like this:
Dest.value2 = Data(i,k).value2
Note: .Value is the default member referred to when you leave it off by referring to just Dest. It's always best to specify and not leave it up to VBA to figure out what you mean. Why use .Value2 instead of just .Value? Read this SO question and the accepted answer.
The transposition is happening here because of the order of a and j.
a = 0
For k = 2 To UBound(Data, 2)
Dest.Offset(a, j) = Data(i, k)
a = a + 1
Next
End If
'Next column
j = j + 1
It's really hard to tell because of the unclear variable names.
If you rename your variables like this:
Dim I as Long --> Dim sourceRow as Long
Dim K as Long --> Dim sourceCol as Long
Dim A as Long --> Dim destRow as Long
Dim J as Long --> Dim destCol as Long
You'll see that's the way they're being currently being used and that what you want to do is swap destRow with destCol.
Rewriting that code with the new variable names gives you:
destRow = 0
For sourceCol = 2 To UBound(Data, 2)
Dest.Offset(destRow, destCol) = Data(sourceRow, sourceCol)
destRow = destRow + 1
Next
End If
'Next column
destCol = destCol + 1
and now you can much more easily see that your loop is incrementing your sourceCol and your destRow. If you now change that to:
destRow = 0
For sourceCol = 2 To UBound(Data, 2)
Dest.Offset(destRow, destCol).Value2 = Data(sourceRow, sourceCol).Value2
destCol = destCol + 1
Next
End If
'Next column
destRow = destRow + 1
You'll see that the loop is now incrementing both source & dest columns. Now you just need to change the incrementers in the outer loop to update the rows in sync and you should be good.
This is a great object lesson in why good names for code "things" are incredibly valuable. Once I sorted out a, i, j & k, it made it very obvious. It appears you're not the original author of this code, but even if you are, it's OK. Most of us start out with horrible names for stuff then slowly learn over time how valuable good names are. It's well worth it to refactor the code to improve these names and others.
A quick shameless plug for the Rubberduck plugin for the VBE. I'm a huge fan and starting to contribute to the project, as well. It will allow you to refactor your code by intelligently renaming variables. As you can imagine, doing a search & replace for i to sourceRow wsourceRowll gsourceRowve you some sersourceRowously broken code! Rubberduck will avoid that problem and add many, many more features that you'll soon wonder how you ever lived without!

Related

Loop not correctly deleting rows in the Worksheet

So here is the task I am required to do.
I have a worksheet in which the user can specify a Column name and an element under the column, once chosen, the macro will find and delete every element with said name.
My issue comes from the final part of the macro, the delete. My loop doesn't delete all the rows, it will only find one instance of the element and delete it, then go to the next element and delete it, leaving every other element with the same name intact.
Here is the function within the macro, I apologize in advance for the poor code quality as I am not well versed in vba.
Function LineDelete() As Variant
Dim NbLignes As Integer
Dim ctr As Integer
Dim ctr2 As Integer
Dim Table As Variant
Worksheets("parametrage_suppr_ligne").Activate
ctr = 1
ctr2 = 1
NbLignes = Cells.Find("*", Range("A1"), , , xlByRows, xlPrevious).Row - 4
ReDim Table(1 To NbLignes, 2)
While ctr <= NbLignes
Table(ctr, 1) = Cells(ctr + 4, 1).Value
Table(ctr2, 2) = Cells(ctr2 + 4, 2).Value
ctr = ctr + 1
ctr2 = ctr2 + 1
Wend
Call FileOpen
Call delInvalidChars
Call OrderRows
Dim newCtr As Integer
Dim rng As Range
Dim rngHeaders As Range
Dim newString As Variant
Dim i As Integer
NbLignes = 0
NbLignes = Cells.Find("*", Range("A1"), , , xlByRows, xlPrevious).Row
Set rngHeaders = Range("1:1")
newCtr = 1
For i = NbLignes To FirstRow Step -1
Set rng = rngHeaders.Find(Table(newCtr, 1))
If Table(newCtr, 1) = rng Then
MsgBox "All is gud!!"
newString = Cells.Find(Table(newCtr, 2))
If Table(newCtr, 2) = newString Then
MsgBox newString
Range(Cells.Find(Table(newCtr, 2)).Address).EntireRow.Delete
newCtr= newCtr + 1
End If
End If
newCtr = newCtr + 1
Next i
End Function
So now to explain a bit what I've done here.
At first I store the options in a 2 dimentional table with a simple loop, in this table I store the name of the column a well as the name of the element under the column that has to be deleted.
After that I call the functions which open a txt file which is then transformed into an excel file, it is in this new excel file that the deletes have to be done.
I then reset the NbLignes variable as well as call new variables.
Here is where the issues begin, I thought that by iterating on the number of lines the new excel file has; the program was going to look for all of the instances of the word in the column and was going to delete them, but so far it will only do it 3 times.
I am totally lost as to what modify to be able to fix this.
Here is what the config table looks like, this is what the user can modify to specify what to delete, it is also what I store inside of the 2d Table:
User can add as many columns and names as needed
EDIT: What the code does now after updating is that it deletes all the elements that have the same name as the first one in the image (fun_h_opcomp), the expected outcome would be that as soon as all those elements are deleted, the program should then pass on to the next one (fun_b_pterm) and so on.
Of course the i was just an Example for that counter and you must use your newCtr counter here, and FirstRow must be set to a value.
Const FirstRow As Long = 1
Dim newCtr As Long 'always use Long for row counting
For newCtr = NbLignes To FirstRow Step -1
Set rng = rngHeaders.Find(Table(newCtr, 1))
If Table(newCtr, 1) = rng Then
MsgBox "All is gud!!"
newString = Cells.Find(Table(newCtr, 2))
If Table(newCtr, 2) = newString Then
MsgBox newString
Range(Cells.Find(Table(newCtr, 2)).Address).EntireRow.Delete
End If
End If
Next newCtr
There is no need to increment/decrement newCtr anymore because this is automatically done by the Next statement.

VBA, Code runs fine in excel 2010, slow and not responding error in 2013

Previously when running my code in 2010 excel version (Version 14.0.7165.5000), it runs in 4 minutes. (however if I run it a second time, it doesnt work)
When switching to 2013 I get 'excel not responding' or it just excel hangs.
The code opens a files from a directory, loads them into my excel sheet and compiles and transforms some data.
I stepped through the code, seems to get past this part and now excel isnt responding on my given sub sub , specifically at this part,
'write
For i = 1 To WorksheetFunction.Min(nRows, UBound(arr, 1))
For j = 1 To nCols
If fromTop Then writeVal = arr(i, j) Else writeVal = arr(UBound(arr, 1) - i + 1, j)
thisWS.Cells(startRow + i - 1, startCol + j - 1).value = writeVal
Next j
Next i
Does anyone know why this is? Is there some function I am using that works in 2010 but not in 2013?
this isn't really an answer. But, I'm not sure the code will format in the comments section. If anyone would care to inform me how to handle this situation in the future, let me know!
Anyway, excel guy, I mean this:
'clear
startCell.Resize(nRows, nCols).ClearContents
instead of:
'clear
For i = 1 To nRows
For j = 1 To nCols
thisWS.Cells(startRow + i - 1, startCol + j - 1).value = ""
Next j
Next i
OK... next would be to change the writeArrToWS sub to use an array to write to the whole range at once. I rewrote the sub, incorporating a modified change from my answer above. I think you'd want:
Public Sub writeArrToWS(arr() As Variant, startCell As Range, fromTop As Boolean, nRows As Long, nCols As Long)
Dim i As Long, j As Long, startRow As Long, startCol As Long
Dim thisWS As Worksheet, totalRange As Range
Set thisWS = startCell.Worksheet
'set the write range
Set totalRange = startCell.Resize(nRows, nCols)
'clear
totalRange.ClearContents
'write
If fromTop Then
totalRange.Value2 = arr
Else
Dim reversedArr() As Variant, swappedRow As Long
ReDim reversedArr(1 To nRows, 1 To nCols)
For i = 1 To nRows
swappedRow = nRows - i + 1
For j = 1 To nCols
reversedArr(swappedRow, j) = arr(i, j)
Next j
Next i
totalRange.Value2 = reversedArr
End If
End Sub
A few things:
It seems like if fromTop is true, you just paste the array to the range... did I misunderstand that? If so, it's almost like you just want a "reverseArray" function/subroutine...
We're basically just generating a new array, "reversedArr", which reverses the order of the rows but leaves the columns alone
Is there any particular reason why you're passing nRows and nCols to the function? Do you ever want to use the function when nRows and nCols is not just the number of rows and columns of the passed array? If no, then I don't think there's a reason to pass those variables, and instead just generate them inside the function from the passed array.

Gather data tidy in Excel using VBA

What the case is:
So I got a "results sample" in excel format that needs filtering and reshaping to look nice. It is a result that will be not identical all the time but it follows similar rules. I have to filter it further and make it a little more tidy. I have figured out the filtering part, but I am not sure how to sort the remaining data, in a tidy way.
What the situation is:
There are six columns involved.
Notice: Real deal is not THAT simple, but what I need can be demonstrated using such a simple example and then I can manage more complex stuff myself I suppose.
For our example we use columns from B to G
The data are set as pairs of a "title" and a value.
For instance, if you look the first example picture I provide, The first detais the pair B3 and C3.
As you can see, looking at the same picture, D3 and E3 is an empty pair.
Same goes for D4 - E4 and F4 - G4 and so on until a last one at B11 - C11.
Starting data example:
[
What I want to achieve:
I would like, using Visual Basic for Applications, to sort the data, starting from let's say for our example B3 (see second picture) and fill three SETS of two columns, (BC, DE, FG) if there are no data inside those cells.
Notice: If a cell like D3 is null then SURELY E3 will be null too so there can be just only one check. I mean we can check either value columns or title columns.
Notice2: The B,D,F or C,E,G columns DON'T have to be sorted. I just want all the not-null values of B,D,F and their respective values from C,E,G gathered together neat so printing will not need 30 pages but just a few (too many spaces between is causing it and I try to automate the cleanup)
Here's something to start with. The first double loop populates a VBA Collection with Range variables that refer to the Cells that contain the titles.
The associated values are obtained by using an offset. The middle double loop performs a bubble sort on the latter (highly inefficient - you might want to replace it with something else). The next if statement creates a 2nd sheet if it doesn't exist on which to write out the results (last loop).
Option Explicit
Sub GatherData()
Dim lastRow As Integer, lastCol As Integer
Dim r As Integer, c As Integer
Dim vals As Collection
Set vals = New Collection
With Sheets(1)
lastCol = .UsedRange.Columns(.UsedRange.Columns.Count).Column
lastRow = .UsedRange.Rows(.UsedRange.Rows.Count).row
For c = 1 To lastCol Step 2
For r = 1 To lastRow
If (Trim(Cells(r, c).Value) <> "") Then
vals.Add .Cells(r, c)
End If
Next
Next
End With
' Bubble Sort
Dim i As Integer, j As Integer
Dim vTemp As Range
For i = 1 To vals.Count - 1
For j = i + 1 To vals.Count
If vals(i).Value > vals(j).Value Then
Set vTemp = vals(j)
vals.Remove j
vals.Add vTemp, vTemp, i
End If
Next j
Next i
Dim sht2 As Worksheet
If ThisWorkbook.Worksheets.Count = 1 Then
Set sht2 = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(1))
Else
Set sht2 = Worksheets(2)
End If
With sht2
r = 3
c = 2
For i = 1 To vals.Count
.Cells(r, c).Value = vals(i).Value
.Cells(r, c + 1).Value = vals(i).Offset(, 1).Value
c = c + 2
If c = 8 Then
r = r + 1
c = 2
End If
Next
End With
End Sub
Here is a method using the Dictionary object. I use early binding which requires setting a reference to Microsoft Scripting Runtime. If you are going to be distributing this, you might want to convert this to late-binding.
We assume that your data is properly formed as you show it above. In other words, all the titles are in even numbered columns; and the results are in the adjacent cell.
We create the dictionary using the Title as the Key, and the adjacent cell value for the Dictionary item.
We collect the information
Transfer the Keys to a VBA array and sort alphabetically
create a "Results Array" and populate it in order
write the results to a worksheet.
I will leave formatting and header generation to you.
By the way, there is a constant in the code for the number of Title/Value pair columns. I have set it to 3, but you can vary that.
Enjoy
Option Explicit
Option Compare Text 'If you want the sorting to be case INsensitive
'set reference to Microsoft Scripting Runtime
Sub TidyData()
'Assume Titles are in even numbered columns
'Assume want ColPairs pairs of columns for output
'Use dictionary with Title as key, and Value as the item
Dim dctTidy As Dictionary
Dim arrKeys As Variant
Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
Dim vSrc As Variant, vRes As Variant
Dim LastRow As Long, LastCol As Long
Dim I As Long, J As Long, K As Long, L As Long
Dim V As Variant
'in Results
Const ColPairs As Long = 3
'Set Source and results worksheet and range
Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet2")
Set rRes = wsRes.Cells(1, 2)
'Read source data into variant array
With wsSrc.Cells
LastRow = .Find(what:="*", after:=.Item(1, 1), _
LookIn:=xlValues, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
LastCol = .Find(what:="*", after:=.Item(1, 1), _
LookIn:=xlValues, searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
vSrc = .Range(.Cells(1, 1), .Cells(LastRow, LastCol))
End With
'Collect the data into a dictionary
Set dctTidy = New Dictionary
For I = 1 To UBound(vSrc, 1)
For J = 2 To UBound(vSrc, 2) Step 2
If vSrc(I, J) <> "" Then _
dctTidy.Add Key:=vSrc(I, J), Item:=vSrc(I, J + 1)
Next J
Next I
'For this purpose, we can do a simple sort on the dictionary keys,
' and then create our results array in the sorted order.
arrKeys = dctTidy.Keys
Quick_Sort arrKeys, LBound(arrKeys), UBound(arrKeys)
'Create results array
ReDim vRes(1 To WorksheetFunction.RoundUp(dctTidy.Count / ColPairs, 0), 1 To ColPairs * 2)
I = 0
J = 0
For Each V In arrKeys
K = Int(I / ColPairs) + 1
L = (J Mod ColPairs) * 2 + 1
vRes(K, L) = V
vRes(K, L + 1) = dctTidy(V)
I = I + 1
J = J + 1
Next V
'write the results
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
With rRes
.Worksheet.Cells.Clear
.Value = vRes
.HorizontalAlignment = xlCenter
End With
End Sub
Sub Quick_Sort(ByRef SortArray As Variant, ByVal first As Long, ByVal last As Long)
Dim Low As Long, High As Long
Dim Temp As Variant, List_Separator As Variant
Low = first
High = last
List_Separator = SortArray((first + last) / 2)
Do
Do While (SortArray(Low) < List_Separator)
Low = Low + 1
Loop
Do While (SortArray(High) > List_Separator)
High = High - 1
Loop
If (Low <= High) Then
Temp = SortArray(Low)
SortArray(Low) = SortArray(High)
SortArray(High) = Temp
Low = Low + 1
High = High - 1
End If
Loop While (Low <= High)
If (first < High) Then Quick_Sort SortArray, first, High
If (Low < last) Then Quick_Sort SortArray, Low, last
End Sub
Assuming we got all variables set and initialized properly, in this example:
Sheets("sheetname").Select ' because stupid things can happen...
For i = 3 To 13
Let newrangeT = "B" & i '
Let newrangeV = "C" & i '
If Sheets("sheetname").Range(newrangeV) <> "" Then
values(Position) = Sheets("sheetname").Range(newrangeV)
titles(Position) = Sheets("sheetname").Range(newrangeT)
Position = Position + 1
Else
' Don't do anything if the fields are null
End If
Next i
Sheets("sheetname").Range("B1:G13").Clear
' We then get each data from the arrays with a For loop.
' We set a columnset variable to 1.
' We set a currentrow variable to 3.
' If columnset is 1 data will enter in B and C and columnset = columnset +1
' Then if columnset is 2 we set data to DE and columnset = columnset +1
' But if columnset is 2we set data to FG and columnset = 1 and currentrow = currentrow +1
' Iterating the arrays will result in a neat setting of the data, but it will add zeros for all the nulls. Thus we need an If statement that will exclude that values checking the TITLE array (that should contain a title instead). if the value is not 0 then... we run what I describe, otherwise we do nothing.
Putting the data in the array is half of the trick.
Then we clear the area.
We set two string variables to declare ranges (actually cell reference) for every cell iterated in the loop. Here I demonstrated only for column set B,C
but we have to do the same for the rest of the columns.
The If statement here checks for null. You might have different needs, so changing the if statement changes the filtering. Here I check if the cells are not null. If the cells of column C contain data, put those data in values array and the respective B data on titles array but where? Position starts as 1 and we then iterate it +1 each time it adds something.
You can set data from an array using this command:
' current_row is set to the first row of the spreadsheet we wanna fill.
Sheets("sheetname").Select ' because stupid things can happen...
newrangeV = "C" & current_row
Sheets("sheetname").Range(newrangeV) = values(j)
The rest is just putting things together.
In any case, I wanna thank both of the people involved in this question, because I might didn't got the solution, but I got an idea of how to do other stuff, like accidentally learning something new. Cheers.

COUNTIF() in 'For' loop

I have a column with nearly 100k and am trying to determine how many times a value occurs repeatedly in that column. I can do it row by row currently, but this is menial as a programmer, through something like =COUNTIF(D:D,D2). Yet that only returns D2 matches in column D.
I need to iterate through all values of D returning countif, therefore revealing all of the values repetitions in the column. I can remove duplicates later! So I have a dev. button a basic sub, or function (man this is new to me) and something along the lines of the most basic for loop ever. Just getting caught up on how to implement the COUNTIF() to to the loop properly.
Right now I'm looking at:
Sub doloop()
Dim i As Integer
i = 1
Do While i < D.Length
Cells(i, 8).Value =CountIf(D:D,D[i])
i = i + 1
Loop
End Sub
That code is incorrect obviously but it is where I'm at and may help for anyone more familiar with other languages.
Use Application.WorksheetFunction.CountIf() in your loop.
Private Sub doloop()
Dim lastRow As Long
Dim d As Double
Dim r As Range
Dim WS As Excel.Worksheet
Dim strValue As String
Dim lRow As Long
'Build your worksheet object
Set WS = ActiveWorkbook.Sheets("sheet1")
'Get the last used row in column A
lastRow = WS.Cells(WS.Rows.count, "D").End(xlUp).Row
'Build your range object to be searched
Set r = WS.Range("D1:D" & lastRow)
lRow = 1
WS.Activate
'Loop through the rows and do the search
Do While lRow <= lastRow
'First, get the value we will search for from the current row
strValue = WS.Range("D" & lRow).Value
'Return the count from the CountIf() worksheet function
d = Application.worksheetFunction.CountIf(r, strValue)
'Write that value to the current row
WS.Range("H" & lRow).Value = d
lRow = lRow + 1
Loop
End Sub
I believe you are trying to write the value to the cell, that is what the above does. FYI, if you want to put a formula into the cell, here is how that is done. Use this in place of WS.Range("H" & lRow).Value = d
WS.Range("H" & lRow).Formula = "=CountIf(D:D, D" & lRow & ")"
Sounds like you may want to look into using tables in Excel and capitalizing on their features like filtering and equation autofill. You may also be interested in using a PivotTable to do something very similar to what you're describing.
If you really want to go about this the programmatic way, I think the solution Matt gives answers your question about how to do this using CountIf. There's a big detriment to using CountIf though, in that it's not very computationally efficient. I don't think the code Matt posted will really be practical for processing the 100K rows mentioned in the OP (Application.ScreenUpdating = false would help some). Here's an alternative method that's a lot more efficient, but less intuitive, so you'll have to decide what suites your needs and what you feel conformable with.
Sub CountOccurances()
'Define Input and Output Ranges
'The best way to do this may very from case to case,
'So it should be addressed seperately
'Right now we'll assume current sheet rows 1-100K as OP specifies
Dim RInput, ROutput As Range
Set RInput = Range("D1:D100000")
Set ROutput = Range("E1:E100000")
'Define array for housing and processing range values
Dim A() As Variant
ReDim A(1 To RInput.Rows.Count, 0)
'Use Value2 as quicker more accurate value
A = RInput.Value2
'Create dictionary object
Set d = CreateObject("Scripting.Dictionary")
'Loop through array, adding new values and counting values as you go
For i = 1 To UBound(A)
If d.Exists(A(i, 1)) Then
d(A(i, 1)) = d(A(i, 1)) + 1
Else
d.Add A(i, 1), 1
End If
Next
'Overwrite original array values with count of that value
For i = 1 To UBound(A)
A(i, 1) = d(A(i, 1))
Next
'Write resulting array to output range
ROutput = A
End Sub
You can also modify this to include the removal of replicates you mentioned.
Sub CountOccurances_PrintOnce()
'Define Input and Output Ranges
'The best way to do this may very from case to case,
'So it should be addressed seperately
'Right now we'll assume current sheet rows 1-100K as OP specifies
Dim RInput, ROutput As Range
Set RInput = Range("D1:D100000")
Set ROutput = Range("F1:F9")
'Define array for housing and processing range values
Dim A() As Variant
ReDim A(1 To RInput.Rows.Count, 0)
'Use Value2 as quicker more accurate value
A = RInput.Value2
'Create dictionary object
Set d = CreateObject("Scripting.Dictionary")
'Loop through array, adding new values and counting values as you go
For i = 1 To UBound(A)
If d.Exists(A(i, 1)) Then
d(A(i, 1)) = d(A(i, 1)) + 1
Else
d.Add A(i, 1), 1
End If
Next
'Print results to VBA's immediate window
Dim sum As Double
For Each K In d.Keys
Debug.Print K & ": " & d(K)
sum = sum + d(K)
Next
Debug.Print "Total: " & sum
End Sub

moving range copy paste

I have a data set of 24 hours of demand (rows) by 365 days (columns) and I need to convert this to one continuous vertical data series. In other words create a macro that copies the second day's data and pastes it below the first and so on through the balance of the year.
I found an answer from Manji that is related (I think..) but I am not experienced enough to adapt this code to what I need. Can someone please point me in the right direction?
Here's what I'm looking at:
Sub Macro1()
'
' Macro1 Macro
'
'
Dim oRange As range
Dim startColumn As String
Dim rangestart As Integer
Dim rangeEnd As Integer
Dim cellcount As Integer
Dim i As Integer
startColumn = "A"
rangestart = 1
rangeEnd = 24
cellcount = rangeEnd - rangestart + 1
For i = 1 To cellcount - 1
Set oRange = ActiveSheet.range(startColumn & rangestart & ":" & startColumn & (rangeEnd - i))
oRange.Copy
oRange.Offset(i, i).PasteSpecial xlPasteAll
Set oRange = ActiveSheet.range(startColumn & (rangeEnd - i + 1) & ":" & startColumn & rangeEnd)
oRange.Copy
oRange.Offset((-1 * cellcount) + i, i).PasteSpecial xlPasteAll
Next i
End Sub
I think something like this might help:
Sub DayHour()
Dim r As Long, c As Long, startRow As Long, hoursColumn As Long
Dim daysRow As Long, i As Long, j As Long
daysRow = 1 ' this is the row where 'day 1', 'day 2' (or similar) is written
hoursColumn = 1 ' this is the column where 'hour 1', 'hour 2' (or similar) is written
r = Cells(Rows.Count, hoursColumn).End(xlUp).Row
c = Cells(daysRow, Columns.Count).End(xlToLeft).Column
For i = daysRow To r
For j = hoursColumn To c
With Sheets(2)
.Cells(j, i) = Cells(i, j)
End With
Next j
Next i
End Sub
It writes the rearranged values in sheet 2 of the excel file. I think that's more or less, what you need. If you don't understand something or this isn't what you wanted, just leave a comment.
Little note: copy&paste in most cases isn't a good solution in VBA.
Edit: Something else came into my mind. You don't have to do that in VBA. Excel has a built-in function to do that.
Here is the explanation:
Select all of your data and press Ctrl+C (important: not right click and copy). Then you go to the area where you want your data to be placed. (note: shouldn't be the same place from where you copied the data)
Now do a right click on the cell and press on Past Special... Activate Transpose and click Ok. The data should be in place now.