I've receieved a report in a rolled up fashion in Excel that I need to flatten out in order to import it into Access. Here's a sample of the row:
What needs to happen is the Customer Account and Name need to be transposed to be adjacent to the Voucher line, and needs to be copied so each voucher line has this information. After the transformation, the data should look like this:
Customer Account | Name | Date | Voucher | Invoice | Transation Text | Currency
Note that the row starting with "USD" denotes the end of records for that customer.
I have successfully implemented the following code:
Sub Process_Transactions()
'turn off some Excel functionality so code runs faster
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
Application.EnableEvents = False
Dim i As Long
For i = 1 To 731055
'Move two columns in
ActiveCell.Offset(0, 2).Select
'Select the customer account and name
Range(ActiveCell, ActiveCell.Offset(1, 1)).Select
'Copy and paste it down two rows and over two columns
Selection.Cut
ActiveCell.Offset(2, -2).Select
ActiveSheet.Paste
'Hop up a couple rows and delete 3 rows before the data that are not useful
Rows(ActiveCell.Offset(-2).Row).Select
Selection.Delete Shift:=xlUp
Selection.Delete Shift:=xlUp
Selection.Delete Shift:=xlUp
'Select the next row
Rows(ActiveCell.Offset(1).Row).Select
'If the first record in the row is not "USD", then we have multiple rows for
'this customer
While (ActiveCell.Offset(0, 2) <> "USD")
'Copy and Paste the customer account and number for each
'transaction row
ActiveCell.Select
Range(ActiveCell.Offset(-1, 0), ActiveCell.Offset(-1, 1)).Select
Selection.Copy
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
ActiveCell.Select
ActiveCell.Offset(1, 0).Select
Wend
'Delete the two rows after the data that we need
ActiveCell.Select
Rows(ActiveCell.Row).Select
Selection.Delete Shift:=xlUp
ActiveCell.Select
Rows(ActiveCell.Row).Select
Selection.Delete Shift:=xlUp
'Move to the next row to start over
ActiveCell.Select
Debug.Print "Current Row: " & i
Next i
'at the end, don't forget to restore the default behavior
'calculate the formulas
Application.Calculate
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayStatusBar = True
Application.EnableEvents = True
End Sub
The problem is that the program is very slow. I let the code run for approximately 10 hours last night, and it only processed 33k. I've got roughly 1.5 mil records to process.
I realize that the technique I am using is actually moving the activecell around, so removing that would likely help. However, I am unsure how to proceed. If this is a lost cause and better suited for a .net implementation, feel free to suggest that.
Your code is jam-packed with Excel-VBA methods that are very inefficient! I'll take a few shots:
Don't use .Select and Selection.. That's super slow.
Why do this
Range(ActiveCell, ActiveCell.Offset(1, 1)).Select
Selection.Cut
when you can do this
Range(ActiveCell, ActiveCell.Offset(1, 1)).Cut
Also don't use ActiveCell to move around your sheet. Just do operations directly on whatever cell or row you need, e.g.
Sheet1.Cells(i,2).Copy
Sheet1.Cells(i,1).Paste
Actually, avoid copy/pasting altogether and just say
Sheet1.Cells(i,1).Value = Sheet1.Cells(i,2).Value
Avoid referring to the same object many times and use With instead. Here, Sheet1 is used twice, so you could write this:
With Sheet1
.Cells(i,1).Value = .Cells(i,2).Value
End With
The above are just examples that you will have to adjust to your circumstances, and there is more to optimise, but they'll get you started. Show us your code once you've cleaned it up, and more advice will come!
The fast way to do this would be to grab large chunks of data into a 2-D variant array
Dim varr as Variant
varr=Worksheets("Sheet1").Range("C5:G10005")
then loop on the array and create another variant 2-d array (varr2)second that looks the way you want it, then write the variant array to another worksheet:
Worksheets("Sheet2").Range("A2:G2")=varr2
You don't have to select a cell on every command you execute.
Here is a try:
Dim i As Long
'Suppose you want to start on cell A1
With ActiveSheet
For i = 1 To 731055
'Move two columns to the right and select the customer account and name
'.Range("C" & i & ":D" & i + 1).Cut
'Cut and paste it down two rows and over two columns
'.Range("A" & i + 2 & ":B" & i + 3).Paste
.Range("A" & i + 2 & ":B" & i + 3).Value = .Range("C" & i & ":D" & i + 1).Value
'Hop up a couple rows and delete 3 rows before the data that are not useful
.Range("A" & i & ":C" & i + 2).EntireRow.Delete
'If the first record in the row is not "USD", then we have multiple rows for
'this customer
While (.Range("C" & i + 1).Value <> "USD")
'Copy and Paste the customer account and number for each
'transaction row
'.Range("A" & i & ":B" & i).Copy
'.Range("A" & i + 1 & ":B" & i + 1).Paste
.Range("A" & i + 1 & ":B" & i + 1).Value = .Range("A" & i & ":B" & i).Value
i = i + 1
Wend
'Delete the two rows after the data that we need
.Range("A" & i + 1 & ":A" & i + 2).EntireRow.Delete
'Move to the next row to start over
Debug.Print "Current Row: " & i
Next i
End With
[edit] i changed a little bit my code to copy only the values (this will be much much faster) instead of copy/paste >> see if you really need to copy paste to keep format or so
[edit] Nick: There were a few numbers that were just a little off, so I've updated the answer to reflect these.
I also posted this on Twitter, and got the following from #VisBasApp:
Sub Process_TransactionsPAT()
Const COL_CUSTOMER_ACC As Long = 3
Const COL_CUSTOMER_NAME As Long = 4
Const COL_CUSTOMER_VOUCHER As Long = 4
Const COL_CUSTOMER_INVOICE As Long = 5
Const COL_CUSTOMER_TRANS As Long = 6
Const COL_CUSTOMER_CURR As Long = 7
Const COL_CUSTOMER_AMT_CUR As Long = 8
Const COL_CUSTOMER_BAL_CUR As Long = 9
Const COL_CUSTOMER_BAL As Long = 10
Const COL_CUSTOMER_DUE_DATE As Long = 11
Const COL_CUSTOMER_COL_CODE As Long = 12
Const TEXT_TO_CHECK As String = "Customer account"
Dim accNumber As Variant
Dim accName As String
Dim index As Long
Dim counter As Long
Dim originalData As Variant
Dim transferedData() As Variant
'turn off some Excel functionality so code runs faster
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
Application.EnableEvents = False
originalData = Range("A1:L720909")
counter = 0
For i = 1 To UBound(originalData, 1)
If originalData(i, COL_CUSTOMER_ACC) = TEXT_TO_CHECK Then
' go to the first row under the text 'Customer Account'
index = i + 1
' get name and account number
accNumber = originalData(index, COL_CUSTOMER_ACC)
accName = originalData(index, COL_CUSTOMER_NAME)
' go to the first row under the text 'Date'
index = index + 2
counter = counter + 1
While (UCase(originalData(index, COL_CUSTOMER_ACC)) <> "USD")
ReDim Preserve transferedData(1 To 12, 1 To counter)
transferedData(1, counter) = accNumber
transferedData(2, counter) = accName
transferedData(3, counter) = originalData(index, COL_CUSTOMER_ACC)
transferedData(4, counter) = originalData(index, COL_CUSTOMER_VOUCHER)
transferedData(5, counter) = originalData(index, COL_CUSTOMER_INVOICE)
transferedData(6, counter) = originalData(index, COL_CUSTOMER_TRANS)
transferedData(7, counter) = originalData(index, COL_CUSTOMER_CURR)
transferedData(8, counter) = originalData(index, COL_CUSTOMER_AMT_CUR)
transferedData(9, counter) = originalData(index, COL_CUSTOMER_BAL_CUR)
transferedData(10, counter) = originalData(index, COL_CUSTOMER_BAL)
transferedData(11, counter) = originalData(index, COL_CUSTOMER_DUE_DATE)
transferedData(12, counter) = originalData(index, COL_CUSTOMER_COL_CODE)
index = index + 1
counter = counter + 1
Wend
' it is not the best technique but for now it works
i = index + 1
counter = counter - 1
End If
Next i
' add data on a new sheet
Sheets.Add
Cells(1, 1) = "Customer Account"
Cells(1, 2) = "Name"
Cells(1, 3) = "Date"
Cells(1, 4) = "Voucher"
Cells(1, 5) = "Invoice"
Cells(1, 6) = "Transaction Left"
Cells(1, 7) = "Currency"
Cells(1, 8) = "Amount in currency"
Cells(1, 9) = "Balance in currency"
Cells(1, 10) = "Balance"
Cells(1, 11) = "Due Date"
Cells(1, 12) = "Collection letter code"
For i = 1 To UBound(transferedData, 2)
For j = 1 To UBound(transferedData, 1)
Cells(i + 1, j) = transferedData(j, i)
Next j
Next i
Columns.AutoFit
'at the end, don't forget to restore the default behavior
'calculate the formulas
Application.Calculate
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayStatusBar = True
Application.EnableEvents = True
End Sub
This takes roughly 2 minutes to parse 750,000 records.
I would throw the data as-is on a database, and write a query to do that. I'll write a query and update the answer when I get home (I'm on my phone, its impossible to write SQL :)
Related
Ok, so im a very basic user..
Im using the "If" function to find dips in data, when a dip is found column E shows "1", all others are "0". But I need that whole row with the "1" and the next row, even if it has a "0" or "1".
I currently have this:
If ActiveCell.Value = "1" Then
Selection.EntireRow.Cut
Sheets("Sheet2").Select
lMaxRows = Cells(Rows.Count, "A").End(xlUp).Row
Range("A" & lMaxRows + 1).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Else
So what I need is to tell it to select the row containing "1" (which it already does), as well as the next row.... the rest should cut and append the data to another worksheet.
Great post on alternatives and more reliable methods than ".Select". After reading, you can adjust your code. How to avoid using Select in Excel VBA
To answer your question, replace
Selection.EntireRow.Cut
with
Range(Selection.EntireRow, Selection.Offset(1, 0).EntireRow).Cut
This should get you a good start, you'll need to add some code to not cut all 5 rows above if some of the are blank because they've already been cut or you could remove blank rows on sheet 2 once this code is done.
Sub GetDipsData()
Dim i As Long
Dim c As Long
Dim LastConsecutiveDip As Long
Dim vLastRow As Long
Sheets("Sheet1").Activate
vLastRow = Cells(Rows.Count, "E").End(xlUp).Row
Application.ScreenUpdating = False
For i = 2 To vLastRow
If Cells(i, "E") = 1 Then
s2LastRow = Sheets("Sheet2").Cells(Rows.Count, "E").End(xlUp).Row
For c = i + 1 To vLastRow
If Cells(c, "E") = 1 Then
LastConsecutiveDip = c
Else
Exit For
End If
Next
If c <> i + 2 Then
'copy 5 above and 5 below
If i < 6 Then
Range(Rows(2), Rows(c).Offset(5, 0).EntireRow).Cut Sheets("Sheet2").Range("A" & s2LastRow)
ElseIf c + 5 > vLastRow Then
Range(Rows(i).Offset(-5, 0), Rows(vLastRow).EntireRow).Cut Sheets("Sheet2").Range("A" & s2LastRow)
Else
Range(Rows(i).Offset(-5, 0), Rows(c).Offset(5, 0).EntireRow).Cut Sheets("Sheet2").Range("A" & s2LastRow)
End If
i = c + 5
Else
'just copy 2 rows
If i + 1 > vLastRow Then
Rows(i).Cut Sheets("Sheet2").Range("A" & s2LastRow)
Else
Range(Rows(i), Rows(i).Offset(1, 0).EntireRow).Cut Sheets("Sheet2").Range("A" & s2LastRow)
i = i + 2
End If
End If
End If
Next
Application.ScreenUpdating = True
End Sub
I am new to programming and |I would like some help with the following:
I need a code that when it reads in cells(x,3)="wall" then for every next row until it "hits" another element, that it to say until cells(x+1,3)<>"", it copies the values of cells A:E of that row to another sheet if these satisfy a specific condition. The code will somehow start like that:
If Cells(x, 3) = "wall" Then
Do Until Cells(x + 1, 2) <> ""
If Cells(x + 1, 4) <> "m2" Then
......
x=x+1
Loop
I would like some help with the part of the code in between.
Try the code below. Make sure that it's looking at the correct cells for your conditions.
Option Explicit
Sub copyCells()
'Some variables to keep track of where we are on the sheets
Dim x As Integer
Dim lastRow As Integer
Dim i As Integer
Sheets("Sheet1").Select
Range("A1").Select
'I used 18 rows in my test set. You'll want to change this to fit your data.
lastRow = 18
i = 1
For x = 1 To lastRow
'Check for the first condition
If Cells(x, 3) = "wall" Then
'Move to the next row
x = x + 1
'Check that this is a row we want to copy
'and we haven't reached the end of our data
Do While Cells(x, 2) = "" And x < lastRow
'Check the second condition
If Cells(x, 4) <> "m2" Then
'Copy and paste to the second sheet
Range("A" & x & ":E" & x).Copy
Sheets("Sheet2").Select
Range("A" & i).Select
ActiveSheet.Paste
'Increment i to keep track of where we are on the second sheet
i = i + 1
End If
'Go back to checking the first sheet
x = x + 1
Sheets("Sheet1").Select
Range("A" & x).Select
Loop
End If
Next x
Application.CutCopyMode = False
End Sub
I need to create a sub to consolidate some data. I have several rows (anywhere from 4k to 20k) that I need to consolidate and sum the values from each column (from C to N).
The input data looks like this:
input
For the output, it should sum the columns for each SKU (Column A) and delete the rest.
Like this:
output
It should be simple enough, but I can’t seem to come up with an appropriate solution. I tried using an array with a scripting dictionary but I can’t figure out how to store more than a single value for each key. Sample (unfinished) code:
Dim sArray As Variant
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
sArray = Range(currentRange).Value
For i = 1 To UBound(sArray, 1)
For j = 3 To UBound(sArray, 2)
If dict.exists(sArray(i, 1)) = False Then
dict.Add sArray(i, 1), sArray(i, j)
Else
'this part is very wrong:
dict(sArray(i, 1)) = dict(sArray(i, j)) + sArray(i, j)
End If
Next
Next
Thank you very much in advance!
Try this, It sums the values in Column Q:AB then paste them back and removes the duplicates.
Sub dupremove()
Dim ws As Worksheet
Dim lastrow As Long
Set ws = Sheets("Sheet12") ' Change to your sheet
With ws
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("C2:N" & lastrow)
.Offset(, 14).FormulaR1C1 = "=SUMIF(C1,RC1,C[-14])"
.Value = .Offset(, 14).Value
.Offset(, 14).ClearContents
End With
With .Range("A1:N" & lastrow)
.Value = .Value
.RemoveDuplicates 1, xlYes
End With
End With
Before:
After:
I came up with the following solution instead and it took 30 seconds to run it (not entirely my own idea, borrowed some code from someplace else):
Sub dupes()
Dim MyRange As Range
Dim RowNum As Long
RowNum = 1
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set MyRange = Range("A2:N14200") 'for test only, on the real sub it's dynamic
MyRange.Sort key1:=Range("A2"), order1:=xlAscending
For Each Row In MyRange
With Cells
While Cells(RowNum, 1) = Cells(RowNum + 1, 1) And Cells(RowNum + 1, 1) <> "" 'very important the second condition or it will continue to loop forever
For i = 3 To 14
Cells(RowNum, i) = Cells(RowNum, i) + Cells(RowNum + 1, i)
Next
Rows(RowNum + 1).EntireRow.Delete
Wend
End With
RowNum = RowNum + 1
Next
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
It's kinda messy but it does the trick. Thanks to everyone!
Hi guys so this is my code:
Sub Biz1_Shift_OnePeriod()
'Shift all values one period to the left
'Message Box Question
Ans = MsgBox("Update data by one year?", vbYesNo + vbQuestion, "Data Update")
If Ans = vbNo Then Exit Sub
'Turn off screen updating & calculation to make code run faster
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim CopyFromWks As Worksheet
Dim CopyToWks As Worksheet
Dim j As Integer
Dim C As Range
'---------------------------------------------------------------------
'Business - Balance Sheet
'
'
'Set the worksheet
Sheets("Balance Sheet").Select
Range("A2").Select
Set CopyToWks = Sheets("Balance Sheet")
Set CopyFromWks = Sheets("Balance Sheet")
'
'Copy data loop from 2nd Historical to 3rd Historical
Set Copyfrom = CopyFromWks.Range("L:L")
Set Copyto = CopyToWks.Range("I:I")
For i = 1 To 1
For j = 1 To 95
For Each C In Copyfrom.Cells(j, i)
If C.Locked = False Then
Copyto(j, i).Value = Copyfrom(j, i).Value
End If
Next
Next
Next
'
'Copy data loop from 1st Historical to 2nd Historical
Set Copyfrom = CopyFromWks.Range("O:O")
Set Copyto = CopyToWks.Range("L:L")
For i = 1 To 1
For j = 1 To 95
For Each C In Copyfrom.Cells(j, i)
If C.Locked = False Then
Copyto(j, i).Value = Copyfrom(j, i).Value
End If
Next
Next
Next
'
'Set Historical Yr 1 to Zero
Set Copyto = CopyToWks.Range("O:O")
For i = 1 To 1
For j = 1 To 95
For Each C In Copyfrom.Cells(j, i)
If C.Locked = False Then
Copyto(j, i).Value = 0
End If
Next
Next
Next
'
'Set Current equal to Zero
Set Copyto = CopyToWks.Range("R:R")
For i = 1 To 1
For j = 1 To 95
For Each C In Copyto.Cells(j, i)
If C.Locked = False Then
Copyto(j, i).Value = 0
End If
Next
Next
Next
What I want to do is shift my columns over to the left. I thought a copy paste method would do and for now I have the last column set to 0. However, I need the last column to retain all its formulas, but have it not be pulling from any data source. I came up with an idea to create another column that would be hidden and storing all the formula there and have that shift over when the macro is triggered. I wanted to ask you guys if there is a better way of going about this and help brainstorm a little bit.
Try
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
I have done the following 2 VBA code in excel. Main purpose is to combine multiple address rows into a single line. Problem is it takes forever to run. Is there anyway I can optimise it?
The data is as such, there is a case# for each of the customer address. The customer address can be split into multiple rows. Example: "Address row 1 - Block 56", "Address row 2 - Parry Avenue", "address row 3 - Postal code". There is a blank space between each new address.
My purpose is to combine the address into a single line, and remove the empty rows in between the case numbers eg "Block 56 Parry Avenue Postal code". There are approx 26K case numbers.
Sub test()
Dim l As Long
Dim lEnd As Long
Dim wks As Worksheet
Dim temp As String
Application.EnableEvents = False
Application.ScreenUpdating = False
Set wks = Sheets("data")
wks.Activate
lEnd = ActiveSheet.UsedRange.Rows.Count
For l = 3 To lEnd
If Not IsEmpty(Cells(l, 1)) Then
Do Until IsEmpty(Cells(l + 1, 4))
temp = Cells(l, 4).Value & " " & Cells(l + 1, 4).Value
Cells(l, 4).Value = temp
Cells(l + 1, 4).EntireRow.Delete
Loop
Else: Cells(l, 1).EntireRow.Delete
Do Until IsEmpty(Cells(l + 1, 4))
temp = Cells(l, 4).Value & " " & Cells(l + 1, 4).Value
Cells(l, 4).Value = temp
Cells(l + 1, 4).EntireRow.Delete
Loop
End If
Next l
End Sub
and the 2nd code I tried
Sub transformdata()
'
Dim temp As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Range("A3").Select
Do Until IsEmpty(ActiveCell) And IsEmpty(ActiveCell.Offset(1, 0))
Do Until IsEmpty(ActiveCell.Offset(1, 3))
temp = ActiveCell.Offset(, 3).Value & " " & ActiveCell.Offset(1, 3).Value
ActiveCell.Offset(, 3).Value = temp
ActiveCell.Offset(1, 3).EntireRow.Delete
Loop
ActiveCell.Offset(1, 0).EntireRow.Delete
ActiveCell.Offset(1, 0).Select
Loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Change the line lEnd = ActiveSheet.UsedRange.Rows.Count. Incorrect way of finding last row. You may want to see This
To delete rows where Cells(l, 1) is empty, use Autofilter. See This
Do not delete rows in a straight loop. Use a reverse loop. Or what you could do is identify the cells that you want to delete in a loop and then delete them in one go after the loop. You may want to see This
Here is a basic example.
Let's say your worksheet looks like this
If you run this code
Sub test()
Dim wks As Worksheet
Dim lRow As Long, i As Long
Dim temp As String
Application.ScreenUpdating = False
Set wks = Sheets("data")
With wks
'~~> Find Last Row
lRow = .Range("C" & .Rows.Count).End(xlUp).Row
For i = lRow To 2 Step -1
If Len(Trim(.Range("C" & i).Value)) <> 0 Then
If temp = "" Then
temp = .Range("C" & i).Value
Else
temp = .Range("C" & i).Value & "," & temp
End If
Else
.Range("D" & i + 1).Value = temp
temp = ""
End If
Next i
End With
End Sub
You will get this output
Now simply run the autofilter to delete the rows where Col D is empty :) I have already give you the link above for the same.
The code below will copy all the data into an array, consolidate it, and add it to a new worksheet. You'll need to make COLUMNCOUNT = the number of columns that contain data.
Sub TransformData2()
Const COLUMNCOUNT = 4
Dim SourceData, NewData
Dim count As Long, x1 As Long, x2 As Long, y As Long
SourceData = Range("A" & Range("D" & Rows.count).End(xlUp).Row, Cells(3, COLUMNCOUNT))
For x1 = 1 To UBound(SourceData, 1)
count = count + 1
If count = 1 Then
ReDim NewData(1 To 4, 1 To count)
Else
ReDim Preserve NewData(1 To 4, 1 To count)
End If
For y = 1 To UBound(SourceData, 2)
NewData(y, count) = SourceData(x1, y)
Next
x2 = x1 + 1
Do
NewData(4, count) = NewData(4, count) & " " & SourceData(x2, 4)
x2 = x2 + 1
If x2 > UBound(SourceData, 1) Then Exit Do
Loop Until IsEmpty(SourceData(x2, 4))
x1 = x2
Next
ThisWorkbook.Worksheets.Add
Range("A1").Resize(UBound(NewData, 2), UBound(NewData, 1)).Value = WorksheetFunction.Transpose(NewData)
End Sub