I would like to convert all my heading of data in Column A
Before:
After:
Is there anyone could help? Thanks so much!
I think this might work for you
Option Explicit
Sub Stackoverflow()
Dim LR As Integer
Dim LC As Integer
Dim LRR As Integer
Dim i As Integer
Dim j As Integer
Dim wss As Object
Dim Sht As Object
Dim wsr As Object
Dim CreateSheetIF As Boolean
Set wss = ActiveWorkbook.ActiveSheet
'Create a sheet for the results
Set Sht = Nothing
On Error Resume Next
Set Sht = ActiveWorkbook.Worksheets("Results")
On Error GoTo 0
If Sht Is Nothing Then
CreateSheetIF = True
Worksheets.Add.Name = "Results"
Else
GoTo Exist
End If
Exist:
Set wsr = ActiveWorkbook.Sheets("Results")
LC = wss.Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To LC
LR = wss.Cells(Rows.Count, i).End(xlUp).Row
For j = 1 To LR - 1
LRR = wsr.Cells(Rows.Count, 1).End(xlUp).Row
wsr.Range("A" & LRR + 1) = wss.Cells(1, i)
wsr.Range("B" & LRR + 1) = wss.Cells(j + 1, i)
Next
Next
End Sub
I haven't spend a lot of time doing this. So the code isn't pretty at all.
But it should work.
The Results will be paste on a new sheet called "Results".
Perhaps:
Sub ReOrganize()
Dim MaxCol As Long, Ic As Long, H As Variant
Dim s1 As Worksheet, s2 As Worksheet
Dim MaxRow As Long, K As Long, Jr As Long
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")
MaxCol = s1.Cells(1, Columns.Count).End(xlToLeft).Column
For Ic = 1 To MaxCol
H = s1.Cells(1, Ic).Value
MaxRow = s1.Cells(Rows.Count, Ic).End(xlUp).Row
K = 2 * Ic - 1
For Jr = 2 To MaxRow
s2.Cells(Jr - 1, K) = H
s2.Cells(Jr - 1, K + 1) = s1.Cells(Jr, Ic).Value
Next Jr
Next Ic
End Sub
Related
I'm new to vba.
I have a list of data (A2:A19) on sheet1 and I need to paste it on sheet2 but for each data I need to skip 7 rows. I tried the code for the paste but failed. I dont know how to do the looping(i think). tq
Here's some code that would do it.
Sub InsertRow()
Dim Src As Range
Dim Dest As Range
Dim x As Long
Dim y As Long
Dim cel As Range
Set Src = ThisWorkbook.Worksheets("Sheet1").Range("a2:a19")
Set Dest = ThisWorkbook.Worksheets("Sheet2").Cells(y, 1)
x = 1
y = ThisWorkbook.Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1).Row
For Each cel In Src
Dest = cel
x = x + 8
Set Dest = ThisWorkbook.Worksheets("Sheet2").Cells(x, 1)
Next
End Sub
Sub copypasteskip()
Dim name As String
Dim src As Variant
Dim dest As Variant
Dim endnumber As Integer
Dim finalrow As Variant
Dim i As Integer
Dim r As Integer
Set src = ThisWorkbook.Worksheets("ImportData")
Set dest = ThisWorkbook.Worksheets("June")
endnumber = Cells(Rows.Count, "A").End(xlUp).Row
finalrow = Worksheets("ImportData").Cells(Rows.Count, "D").End(xlUp).Row
'MsgBox "ok"
For r = 11 To endnumber
'name = Cells(r, "A").Value
For i = 14 To finalrow
Worksheets("ImportData").Cells(i, "D").Copy
Worksheets("June").Cells(r, "A").PasteSpecial xlPasteAll
Next i
r = r + 7
Next r
End Sub
I have several sheets with numeric data in columns B up to Column I, and and dates in column J. I've found and edited this macro which I thought would give me the averages and the totals of each column for all sheets. However all it seems to do is give me the total for Column I on each sheet. I'm quite new to VBA and I've got into a bit of a mess with this. I'm wondering if I'm making a basic mistake somewhere?
Sub CalcOnSheets2()
Application.ScreenUpdating = False
Dim Row As Integer
Dim lastrow As Long
Dim ActiveWorksheet As Long
Dim ThisWorksheet As Long
Dim N As Integer
Dim x As Integer
x = Sheets.Count
For N = 2 To x
lastrow = Sheets(N).Cells(Rows.Count, "D").End(xlUp).Row
Sheets(N).range("a1:J" & lastrow + 3).Columns.AutoFit
If lastrow > 1 Then
For Row = 3 To lastrow
Sheets(N).range("B1:J" & lastrow + 3).NumberFormat = "£#,##0.00);(£#,##0.00)"
Next
Dim r As range, j As Long, k As Long, z As Long
j = Sheets(N).range("B2").End(xlToRight).Column
For k = 2 To j - 1
Set r = Sheets(N).range(Sheets(N).Cells(1, k), Sheets(N).Cells(1, k).End(xlDown))
r.End(xlDown).Offset(2, 0) = WorksheetFunction.Sum(r)
r.End(xlDown).Offset(3, 0) = WorksheetFunction.Average(r)
Next k
Else
MsgBox ("There is no data at column D")
End If
Application.ScreenUpdating = True
range("A1").Select
Next N
End Sub
I fixed a few things. Your for loops weren't closing out correctly. Keep going on learning VBA! There are definitely easier ways to lick this problem, but hey this one seems to work so what the heck. Here is the updated code, hopefully it works for you...
Sub CalcOnSheets2()
Application.ScreenUpdating = False
Dim Row As Integer
Dim lastrow As Long
Dim ActiveWorksheet As Long
Dim ThisWorksheet As Long
Dim N As Integer
Dim r As Range, j As Long, k As Long, z As Long
Dim x As Integer
x = Sheets.Count
For N = 2 To x
lastrow = Sheets(N).Cells(Rows.Count, "D").End(xlUp).Row
Sheets(N).Range("a1:J" & lastrow + 3).Columns.AutoFit
If lastrow > 1 Then
For Row = 3 To lastrow
Sheets(N).Range("B1:I" & lastrow + 3).NumberFormat = "£#,##0.00;(£#,##0.00)"
Next
j = Sheets(N).Range("B2").End(xlToRight).Column
For k = 2 To j - 1
Set r = Sheets(N).Range(Sheets(N).Cells(1, k), Sheets(N).Cells(1, k).End(xlDown))
r.End(xlDown).Offset(2, 0) = WorksheetFunction.Sum(r)
r.End(xlDown).Offset(3, 0) = WorksheetFunction.Average(r)
Next k
Else
MsgBox ("There is no data at column D")
End If
Range("A1").Select
Next N
Application.ScreenUpdating = True
End Sub
A little simplified:
Sub CalcOnSheets2()
Dim lastrow As Long
Dim ws As Worksheet
Dim k As Long, r As Range
Application.ScreenUpdating = False
For Each ws In ActiveWorkbook.Worksheets
lastrow = ws.Cells(Rows.Count, "D").End(xlUp).Row
ws.Range("A1:J" & lastrow + 3).Columns.AutoFit
If lastrow > 1 Then
ws.Range("B1:J" & lastrow + 3).NumberFormat = "£#,##0.00;(£#,##0.00)"
For k = 2 To ws.Range("B2").End(xlToRight).Column - 1
Set r = ws.Range(ws.Cells(k, 1), ws.Cells(k, lastrow))
ws.Cells(lastrow + 2, k) = WorksheetFunction.Sum(r)
ws.Cells(lastrow + 3, k) = WorksheetFunction.Average(r)
Next k
Else
MsgBox ("There is no data at column D")
End If
Next ws
Application.ScreenUpdating = True
End Sub
I am trying to find a workaround as transpose will not fit my data size, which is giving me an error. What do I added in right before the end of the loop -before the Next- to paste the data on a new sheet? Will this slow down the macro it the output is 100,000 lines
After reviewing the code I realized that if I make the range to a certain number it works and +1 row after that it errors out. Turns out transpose is to blame.
For Q = 1 To Data + 1
n = n + 1
ReDim Preserve var(1 To 3, 1 To n)
var(1, n) =
For R = 2 To 6
var(r, n) =
Next R
var(1, n) =
var(2, n) =
Next Q
Next_Loop:
Next P
With this workbook.sheet1
If Q>= 2 Then
.Range("a1").Resize(n, 6) = WorksheetFunction.Transpose(var)
End If
The result should be instead of pasting all the data at the end, it pastes the data after each iteration (unless it slows down the macro). Next iteration would be below the previous line of data. etc.
thank you for any insight
Here is an option for you to try.
Sub LongColumnToAFewColumns()
Dim wsF As Worksheet, WST As Worksheet
Dim rf As Range, rT As Range
Dim R As Long, j As Integer
' initialize
Set wsF = ActiveSheet
Set WST = Sheets.Add
WST.Name = "Results"
j = 1
For R = 1 To wsF.Cells(Rows.Count, 1).End(xlUp).Row Step 65536
wsF.Cells(R, 1).Resize(65536).Copy
WST.Cells(j, 1).PasteSpecial xlPasteValues
WST.Cells(j, 1).PasteSpecial xlPasteValues
j = j + 1
Next R
End Sub
If you want one long column cut into a few long rows, then use this.
Sub LongColumnToAFewRows()
Dim wsF As Worksheet, WST As Worksheet
Dim rf As Range, rT As Range
Dim R As Long, j As Integer
' initialize
Set wsF = ActiveSheet
Set WST = Sheets.Add
WST.Name = "Results2"
j = 1
For R = 1 To wsF.Cells(Rows.Count, 1).End(xlUp).Row Step Columns.Count
wsF.Cells(R, 1).Resize(Columns.Count).Copy
WST.Cells(j, 1).PasteSpecial xlPasteValues, Transpose:=True
j = j + 1
Next R
End Sub
One more for consideration.
Sub testing()
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim ptrSource As Long
Dim ptrDest As Long
Dim colDest As Long
Set wsDest = Sheets.Add
wsDest.Name = "Results"
Set wsSource = Worksheets("Sheet1")
colDest = 1
ptrSource = 1
ptrDest = 1
Do While Len(wsSource.Cells(ptrSource, 1)) > 0
wsDest.Cells(ptrDest, colDest) = wsSource.Cells(ptrSource, 1)
If colDest = Columns.Count Then
colDest = 0
ptrDest = ptrDest + 1
End If
ptrSource = ptrSource + 1
colDest = colDest + 1
Loop
Set wsDest = Nothing
Set wsSource = Nothing
End Sub
I have a function that looks up values across sheets and sums the values. It works so long as the value it is looking up exists across all sheets. If the value does not exist, I'd just like to set the result value to 0.
Sub lookupSum3()
Dim myVlookupResult As Double
Dim myTableArray As Range
Dim myVlookupSum As Double
Dim i As Integer
Dim sheetCount As Integer
Dim ws As Worksheet
Dim ws1 As Worksheet
Dim j As Integer
Dim rowCount As Integer
Set ws1 = Sheets(1)
sheetCount = Sheets.count
rowCount = ws1.Range("A1", ws1.Range("A1").End(xlDown).End(xlDown).End(xlUp)).Rows.count
i = 2
j = 2
Do While j <= rowCount
Do While i <= sheetCount
Set ws = Sheets(i)
Set myTableArray = ws.Range("A:N")
myVlookupResult = Application.vlookup(ws1.Range("A" & j), myTableArray, 5, False)
If IsError(myVlookupResult) = True Then
myVlookupResult = 0
End If
myVlookupSum = myVlookupSum + myVlookupResult
i = i + 1
Loop
i = 2
ws1.Range("B" & j) = myVlookupSum
myVlookupSum = 0
j = j + 1
Loop
MsgBox rowCount
End Sub
The code will show a run-time error '13' for the line myVlookupResult = Application.vlookup(ws1.Range("A" & j), myTableArray, 5, False)
Am I handling the error incorrectly?
i have a hug excel table:
I need a formula to move data to the first cell, like below.
please help me to do that.
This works. Just be sure to set the source_rng to the range that you want. Should scale up well too. EDIT: realize now that this doesn't preserve color, will work on that
Sub main()
Dim ws As Worksheet
Dim source_rng As Range
Dim target_rng As Range
Dim source_data() As Variant
Dim clean_data() As Variant
Dim column_count As Long
Dim row_count As Long
Dim i As Long
Dim j As Long
Dim k As Long
Set ws = ActiveSheet
Set source_rng = ws.Range("A1:F19200")
column_count = source_rng.Columns.Count
row_count = source_rng.Rows.Count
ReDim source_data(1 To row_count, 1 To column_count)
ReDim clean_data(1 To row_count * column_count, 1)
source_data = source_rng
k = 1
For j = 1 To row_count
For i = 1 To column_count
If source_data(j, i) <> "" Then
k = k + 1
End If
Next i
Next j
ReDim clean_data(1 To k, 1)
k = 1
For j = 1 To row_count
For i = 1 To column_count
If source_data(j, i) <> "" Then
clean_data(k, 0) = source_data(j, i)
k = k + 1
End If
Next i
Next j
source_rng.Clear
Set target_range = ThisWorkbook.ActiveSheet.Range("A1:A" & UBound(clean_data))
target_range.value = clean_data
End Sub