I am uploading a Tabular data into my SQL database.
The following is the original look of the data.
I want to take each temperature (Y axis) in a column and then each gravity (X Axis) in next Column, followed by the intersecting value.
Like This:
i got helped from a guy from ExcelForum. Here is the Macro Code, that solved my problem.
Option Explicit
Sub transpose_data()
Dim lrow As Long, lcol As Long, a As Long, i As Long, j As Long
Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = "Output"
a = 1
With Worksheets("Original")
lrow = .Range("A" & .Rows.Count).End(xlUp).Row
lcol = .Range("IV1").End(xlToLeft).Column
For i = 2 To lrow
For j = 2 To lcol
Worksheets("Output").Cells(a, 1).Value = .Cells(i, 1).Value
Worksheets("Output").Cells(a, 2).Value = .Cells(1, j).Value
Worksheets("Output").Cells(a, 3).Value = .Cells(i, j).Value
a = a + 1
Next j
Next i
End With
Worksheets("Output").Columns("A:C").NumberFormat = "0.00"
End Sub
Make sure to change the Sheet name to 'Original' in order to have this code working.
Related
I have the code below to fill all blank cells in a selection with the value from above. I am trying to do the opposite, fill up based on the value below. I think I need to make it loop from the bottom of the selection but don't know how to do that. See below for the result I am going for.
1 1
2
2 2
3
3
3 3
Sub FillDown()
Dim columnValues As Range, i As Long
Set columnValues = Selection
For i = 1 To columnValues.Rows.Count
If columnValues.Cells(i, 1).Value = "" Then
columnValues.Cells(i, 1).Value = columnValues.Cells(i - 1, 1).Value
End If
Next
End Sub
Iterate from the bottom up: For i = columnValues.Rows.Count to 1 Step -1
And change the columnValues.Cells(i - 1, 1).Value to columnValues.Cells(i + 1, 1).Value
Sub FillDown()
Dim columnValues As Range
Set columnValues = Selection
Dim i As Long
For i = columnValues.Rows.Count To 1 Step -1
If columnValues.Cells(i, 1).Value = "" Then
columnValues.Cells(i, 1).Value = columnValues.Cells(i + 1, 1).Value
End If
Next
End Sub
Before:
After:
I would do this slightly differently and populate ranges at a time rather than cells at a time:
Sub FillUp()
Dim CurrRow As Long, FillRow As Long, LastRow As Long
CurrRow = 1
LastRow = Range("A" & Rows.Count).End(xlUp).Row
Do Until CurrRow >= LastRow
If Not IsEmpty(Range("A" & CurrRow + 1)) Then
CurrRow = CurrRow + 1
Else
FillRow = Range("A" & CurrRow).End(xlDown).Row - 1
Range("A" & CurrRow & ":A" & FillRow).Value = Range("A" & CurrRow).Value
CurrRow = FillRow + 1
End If
Loop
End Sub
Using the .end property of a cell reference will allow you to do that which means you are posting less times to the sheet, this will make a big difference in performance if there are large volumes of data or if there are many calculations in the sheet
I know that Scott Craner already knows this but since an answer was posted making reference to optimize performance, I'm pretty sure this is the best approach.
Dim myArray(), i As Long
myArray = columnValues
For i = UBound(myArray) - 1 To LBound(myArray, 1) Step -1
If myArray(i, 1) = "" Then
myArray(i, 1) = myArray(i + 1, 1)
End If
Next i
columnValues = myArray
I built a COVID model using UVA data. That data is currently unavailable so I've found another data source. Of course, the new data is not in the same format. So rather than starting from scratch, I'm importing the new data in the format the model was coded for. The new data looks like this...
The new data files are broken up into a Confirmed file, a Deaths file and a Recovered file. Each file is 267 rows and goes out to column EH with a new column added daily. I have a macro for each file. The Confirmed file takes about a minute - minute and a half to run. And when done it looks like this...
I don't import any of the confirmed = 0 data points. I've added the population/pop density columns to delete all the countries I don't care about (those with population = 0). This file has about 6800 rows and of course, this will also grow daily. When the Confirmed file is imported, of course the next thing is Deaths. When I try to import the Deaths file excel goes to 'Not Responding' state and doesn't finish. I've waited on the Deaths macro for about an hour before I killed it and it's still not done. I can see that the correct numbers are being put into the correct column in my consolidated file but it really shouldn't take so long or lock up excel like this. I realize that three For Loops is going through a lot of cells a lot of times. Is there a better way to do this?
Here is the Deaths import code:
Sub ImportCSSEDeaths()
Dim i As Variant
Dim j As Variant
Dim k As Variant
Dim lastrow As Long
Dim clastrow As Long
Dim lastcol As Long
Dim dte As Date
Dim filePath As String
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Dim cws As Excel.Worksheet
Set cws = ThisWorkbook.Sheets("Raw_Data")
lastrow = cws.Cells(Rows.count, "a").End(xlUp).Row
filePath = "C:\Users\chris.h\Desktop\COVID\Other_Data\CSSE\CSSE_Deaths.xlsx"
Set wb = Excel.Workbooks.Open(filePath)
Set ws = wb.Worksheets(1)
clastrow = cws.Cells(Rows.count, "b").End(xlUp).Row
lastrow = ws.Cells(Rows.count, "b").End(xlUp).Row
lastcol = ws.Cells(1, Columns.count).End(xlToLeft).Column
For i = 2 To clastrow
For j = 2 To lastrow
For k = 3 To lastcol
If cws.Cells(i, "a").Value = ws.Cells(j, "a").Value And _
cws.Cells(i, "b").Value = ws.Cells(j, "b").Value And _
cws.Cells(i, "c").Value = ws.Cells(1, k).Value Then
cws.Cells(i, "e").Value = ws.Cells(j, k).Value
cws.Cells(i, "e").NumberFormat = "#,##0"
End If
Next k
Next j
Next i
wb.Close False
End Sub
If more code is needed, I'll provide.
Thanks to #Tom and #Nacorid the following array based code works much faster! Only takes a min or two.
k = 0
For i = 2 To lastrow
For j = 3 To lastcol
'puts country row deaths into array
If ws.Cells(i, j).Value <> 0 Then
ReDim Preserve deaths(k)
deaths(k) = ws.Cells(i, j).Value
k = k + 1
End If
Next j
'finds startdate in new data
For j = 3 To lastcol
If deaths(0) = ws.Cells(i, j).Value Then
startDate = ws.Cells(1, j).Value
Exit For
End If
Next j
Debug.Print startDate
clastrow = cws.Cells(Rows.count, "b").End(xlUp).Row
'finds startdate in compiled data and enters array values down column e
For j = 2 To clastrow
If cws.Cells(j, "a").Value = ws.Cells(i, "a").Value And _
cws.Cells(j, "b").Value = ws.Cells(i, "b") And _
cws.Cells(j, "c").Value = startDate Then
count = j
For k = 0 To UBound(deaths)
cws.Cells(count, "e").Value = deaths(k)
count = count + 1
Next k
End If
Next j
Next i
This should be an easy problem to solve, but I am extremely unfamiliar with VBA so I need some help.
Essentially, I want to copy data given to me (finite column range, but dynamic rows), and paste it transposed into a second sheet within excel. From there, I need to convert all the values in columns D,E,F, and H to fractions out of 12. I'm pretty sure I'm 99% of the way there, but the last step (converting to fraction text) is being performed in the wrong worksheet. I've tried using the .Activate function as well as setting the correct worksheet, but neither work. There's got to be an easy fix to this that I'm missing. Note: this is my first time ever coding in VBA so take it easy on me. Code is below:
Option Explicit
Sub FormatData()
Dim ws As Worksheet
' create a new worksheet, and name it "Master"
Set ws = ThisWorkbook.Worksheets.Add(after:=ThisWorkbook.Worksheets(1))
ws.Name = "Master"
' copy the UsedRange and Transpose
Worksheets("Sheet1").UsedRange.Copy
ws.Range("A1").PasteSpecial xlPasteAll, Transpose:=True
Sheets("Master").Activate
Dim i As Long, N As Long, j As Long
N = Cells(Rows.Count, "D").End(xlUp).Row
j = 2
For i = 2 To N
Cells(i, "D") = WorksheetFunction.Text(Cells(i, "D"), "0 0/12")
j = j + 1
Next i
j = 2
For i = 2 To N
Cells(i, "E") = WorksheetFunction.Text(Cells(i, "E"), "0 0/12")
j = j + 1
Next i
j = 2
For i = 2 To N
Cells(i, "F") = WorksheetFunction.Text(Cells(i, "F"), "0 0/12")
j = j + 1
Next i
j = 2
For i = 2 To N
Cells(i, "H") = WorksheetFunction.Text(Cells(i, "H"), "0 0/12")
j = j + 1
Next i
End Sub
first only do only one loop and do all four conversions inside that one loop. Second, j is not doing anything, you can omit it.
Sub FormatData()
Dim ws As Worksheet
' create a new worksheet, and name it "Master"
Set ws = ThisWorkbook.Worksheets.Add(after:=ThisWorkbook.Worksheets(1))
With ws
.Name = "Master"
' copy the UsedRange and Transpose
Worksheets("Sheet1").UsedRange.Copy
.Range("A1").PasteSpecial xlPasteAll, Transpose:=True
Dim i As Long, N As Long
N = .Cells(.Rows.Count, "D").End(xlUp).Row
For i = 2 To N
.Cells(i, "D") = Application.WorksheetFunction.Text(.Cells(i, "D"), "# ??/12")
.Cells(i, "E") = Application.WorksheetFunction.Text(.Cells(i, "E"), "# ??/12")
.Cells(i, "F") = Application.WorksheetFunction.Text(.Cells(i, "F"), "# ??/12")
.Cells(i, "H") = Application.WorksheetFunction.Text(.Cells(i, "H"), "# ??/12")
Next i
End With
End Sub
The issue is that up to a certain point, each column is copied to the right, and then it suddenly starts going to the left, and ignoring a column.
I didn't write the thing, have as yet been unable to pick it apart to even attempt to solve it properly. I've fiddled with it, but haven't gotten any useful results to go off of.
For colx = 2 To maxColumns Step 2
ActiveSheet.Columns(colx).Insert
ActiveSheet.Columns(colx - 1).Interior.Color = RGB(255, 153, 0)
Next
maxRows = ActiveSheet.UsedRange.Rows.Count
maxColumns = ActiveSheet.UsedRange.Columns.Count * 2 + 1
For colx = 2 To maxColumns Step 2
For iRow = 1 To maxRows
WorksheetFunction.CountA (Columns(1))
'If there is a comment, paste the comment text into column D and delete the original comment.
ActiveSheet.Cells(iRow, colx).Value = Trim(ActiveSheet.Cells(iRow, colx - 1).Value)
Next iRow
Next
As you can see in the image below, Rental Amount and Deposit Amount have worked, though Deposit Amount has also happend in the column AL, which should have Rent Frequency. Similarly Column AT should have "PROPERTY TYPE" and AV should have "FURNISHED TYPE" and so on and so forth...
Replace your entire code with this:
Option Explicit
Sub Macro1()
Dim LCol As Long, LRow As Long, i as Long, j as Long
With ThisWorkbook.Worksheets("Sheet1")
LCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
LRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("A1", .Cells(LRow, LCol)).Interior.Color = RGB(255, 153, 0)
For i = 1 To (LCol*2 - 1) Step 2
.Columns(i+1).Insert
For j = 1 To LastRow
.Cells(j, i+1).Value = Trim(.Cells(j, i).Value)
Next j
Next i
End With
End Sub
I have to create a vba script that takes data from a column of another table in Excel ("Days Of Last Update", which is decimal), and then makes a sum based if the day are above 2 (showing the result in a new column).
It seems to be very simple, but I am a beginner and have no idea how to proceed.
UPDATE:
Hello everyone, thanks for the help. Now I have a new problem, still in this project. Here is what I've done:
The RawData's sheet have a column named "Days Since Last Update", that tells me when the Service Request of the product is updated. So, I created a new column with this formula =IF(N:N>2,1,0), to tells me if the Days Since Last Updated are above 2. I refreshed my pivot table to get this new column, did a Sum of the data, and get what I previously wanted, but, when the Update function of the worksheet run, the new column of the pivot table, as well as the column of the RawData with the formula, are gone. In the code (that isn't done by me) of the Update function, there was something like this:
Worksheets("Pivot table").PivotTables("PivotTable1").PivotCache.Refresh
It has something to do with my problem?
Please find the sample data sheet appended below.
VBA Code is appended below.
Sub Extract_Values()
Dim wks As Worksheet
Dim startRow As Integer
Dim lastRow As Integer
Dim vArray As Variant
Dim vNewArray As Variant
Dim i As Integer, j As Integer
Dim Counter1 As Integer, Counter2 As Integer
startRow = 2
Set wks = Sheets("Sheet1")
With wks
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
vArray = .Range("A" & startRow & ":D" & lastRow).Value2
For i = 1 To UBound(vArray)
If vArray(i, 4) = "Y" Then
Counter1 = Counter1 + 1
End If
Next i
ReDim vNewArray(1 To Counter1, 1 To 2)
For j = 1 To UBound(vArray)
If vArray(j, 4) = "Y" Then
Counter2 = Counter2 + 1
vNewArray(Counter2, 1) = vArray(j, 1)
vNewArray(Counter2, 2) = vArray(j, 2)
End If
Next
End With
Range("E" & startRow & ":F" & startRow + Counter1 - 1) = vNewArray
Range("E" & startRow & ":E" & startRow + Counter1 - 1).Select
Selection.NumberFormat = "m/d/yyyy"
Range("F" & startRow + Counter1).Select
End Sub
I am also a beginner setting proper VBA code in cell F8 which I have calculated Excel in-built Count Function.
COLUMN D Contains IF Formula like 'D2=IF(B2>1,"Y","N")'
HTH
Try
Dim RowCount As Integer
Dim NewRow As Integer
RowCount = 2
NewRow = 2
Do Until RowCount > Cells(2, 2).End(xlDown).Row
If Cells(RowCount, 2) > 1 Then
Range(Cells(NewRow, 5), Cells(NewRow, 6)).Value = Range(Cells(RowCount, 1), Cells(RowCount, 2)).Value
NewRow = NewRow + 1
End If
RowCount = RowCount + 1
Loop
End Sub