I have 2 workbooks. One wb acts as a database (divided into users), while the other is used to pull data from that wb based on a date. I looped the macro and at first it seems to pull data only from the first sheet. See NOTE below
Dim y As Integer
Dim r As Integer
Dim WS_Count As Integer
Dim I As Integer
r = CollateSh3.Range("D" & Rows.Count).End(xlUp).Row + 1
y = 3
WS_Count = wbLog.Worksheets.Count
For I = 1 To WS_Count
Do Until wbLog.Sheets(I).Range("A" & y) = ""
If wbLog.Sheets(I).Range("B" & y).Value = RequiredDate Then
CollateSh3.Range("A" & r).Value = wbLog.Sheets(I).Range("D" & y).Value
CollateSh3.Range("C" & r).Value = wbLog.Sheets(I).Range("F" & y).Value
CollateSh3.Range("D" & r).Value = wbLog.Sheets(I).Range("G" & y).Value
CollateSh3.Range("E" & r).Value = wbLog.Sheets(I).Range("H" & y).Value
CollateSh3.Range("F" & r).Value = wbLog.Sheets(I).Range("I" & y).Value
CollateSh3.Range("G" & r).Value = wbLog.Sheets(I).Range("J" & y).Value
CollateSh3.Range("H" & r).Value = wbLog.Sheets(I).Range("K" & y).Value
CollateSh3.Range("I" & r).Value = wbLog.Sheets(I).Range("L" & y).Value
CollateSh3.Range("K" & r).Value = wbLog.Sheets(I).Range("N" & y).Value
r = r + 1
y = y + 1
Else
y = y + 1
End If
Loop
'MsgBox wbLog.Sheets(I).Name
Next I
EDIT: I think I might have useful additional info. It seems that the macro doesn't skip. When I tried to add more entries to the database file, it pulls data, except that it starts at the row where it ended on the previous sheet. For e.g., if it ended on row 9 on sh1, the code starts at row 10 on sh2.
How do I reset the increment before going to the next sheet?
Here's the edited code. I opted to add it after the end of the loop, because that way I'd remember it for future reference. Thanks #PatricK!
Dim y As Integer
Dim r As Integer
Dim WS_Count As Integer
Dim I As Integer
r = CollateSh3.Range("D" & Rows.Count).End(xlUp).Row + 1
y = 3
WS_Count = wbLog.Worksheets.Count
For I = 1 To WS_Count
Do Until wbLog.Sheets(I).Range("A" & y) = ""
If wbLog.Sheets(I).Range("B" & y).Value = RequiredDate Then
CollateSh3.Range("A" & r).Value = wbLog.Sheets(I).Range("D" & y).Value
CollateSh3.Range("C" & r).Value = wbLog.Sheets(I).Range("F" & y).Value
CollateSh3.Range("D" & r).Value = wbLog.Sheets(I).Range("G" & y).Value
CollateSh3.Range("E" & r).Value = wbLog.Sheets(I).Range("H" & y).Value
CollateSh3.Range("F" & r).Value = wbLog.Sheets(I).Range("I" & y).Value
CollateSh3.Range("G" & r).Value = wbLog.Sheets(I).Range("J" & y).Value
CollateSh3.Range("H" & r).Value = wbLog.Sheets(I).Range("K" & y).Value
CollateSh3.Range("I" & r).Value = wbLog.Sheets(I).Range("L" & y).Value
CollateSh3.Range("K" & r).Value = wbLog.Sheets(I).Range("N" & y).Value
r = r + 1
y = y + 1
Else
y = y + 1
End If
Loop
y = 3 'to reset increment before moving on to next sheet
Next I
Related
This loop to copies the values from one sheet's columns to another sheet's columns:
Dim ExposureDataInput As Worksheet
Dim ManualSimulation As Worksheet
Set EDI = Sheets("ExposureDataInput")
Set MS = Sheets("ManualSimulation")
Dim i As Integer
Dim n As Integer
For i = 2 To EDI.Range("B" & Rows.Count).End(xlUp).Row
If EDI.Range("B" & i).Value > 0 Then
n = MS.Range("A" & Rows.Count).End(xlUp).Row + 1
MS.Range("A" & n).Value = EDI.Cells(i, 1).Value
n = MS.Range("B" & Rows.Count).End(xlUp).Row + 1
MS.Range("B" & n).Value = EDI.Cells(i, 2).Value
n = MS.Range("C" & Rows.Count).End(xlUp).Row + 1
MS.Range("C" & n).Value = EDI.Cells(i, 4).Value
n = MS.Range("D" & Rows.Count).End(xlUp).Row + 1
MS.Range("D" & n).Value = EDI.Cells(i, 6).Value
n = MS.Range("E" & Rows.Count).End(xlUp).Row + 1
MS.Range("E" & n).Value = EDI.Cells(i, 8).Value
n = MS.Range("F" & Rows.Count).End(xlUp).Row + 1
MS.Range("F" & n).Value = EDI.Cells(i, 10).Value
n = MS.Range("G" & Rows.Count).End(xlUp).Row + 1
MS.Range("G" & n).Value = EDI.Cells(i, 12).Value
End If
Next i
I tried the same principal to get the col A:A from one sheet to a row in another sheet:
Dim ExposureDataInput As Worksheet
Dim HistoricalDataandExcessReturns As Worksheet
Set EDI = Sheets("ExposureDataInput")
Set HDaER = ThisWorkbook.Worksheets("HistoricalDataandExcessReturns")
Dim k As Integer
Dim y As Integer
For k = 2 To EDI.Range("B" & Rows.Count).End(xlUp).Row
If EDI.Range("B" & k).Value > 0 Then
y = HDaER.Range(Columns.Count & 1).End(xlToLeft).Column + 1
HDaER.Range(y & 1).Value = EDI.Cells(1, k).Value
y = HDaER.Range(Columns.Count & 2).End(xlToLeft).Column + 1
HDaER.Range(y & 2).Value = EDI.Cells(2, k).Value
End If
Next k
The i in the column to column works. When I try with k in a column to row it gives me
Run-time error '1004'.
How can I copy a column to a row?
I believe the issue lies with the way you are trying to get the last Column, please have a look at my answer below:
The first sub could be written as:
Dim ExposureDataInput As Worksheet
Dim ManualSimulation As Worksheet
Set EDI = Sheets("ExposureDataInput")
Set MS = Sheets("ManualSimulation")
Dim i As Long
Dim n As Long
For i = 2 To EDI.Range("B" & EDI.Rows.Count).End(xlUp).Row
If EDI.Range("B" & i).Value > 0 Then
n = MS.Cells(MS.Rows.Count, "A").End(xlUp).Row + 1
'get the next free row without data on Column A
MS.Range("A" & n).Value = EDI.Cells(i, 1).Value
MS.Range("B" & n).Value = EDI.Cells(i, 2).Value
MS.Range("C" & n).Value = EDI.Cells(i, 4).Value
MS.Range("D" & n).Value = EDI.Cells(i, 6).Value
MS.Range("E" & n).Value = EDI.Cells(i, 8).Value
MS.Range("F" & n).Value = EDI.Cells(i, 10).Value
MS.Range("G" & n).Value = EDI.Cells(i, 12).Value
End If
Next i
The second sub could be written as:
Dim ExposureDataInput As Worksheet
Dim HistoricalDataandExcessReturns As Worksheet
Set EDI = Sheets("ExposureDataInput")
Set HDaER = ThisWorkbook.Worksheets("HistoricalDataandExcessReturns")
Dim k As Long
Dim y As Long
For k = 1 To EDI.Cells(EDI.Rows.Count, "B").End(xlUp).Row
If EDI.Range("B" & k).Value > 0 Then
y = HDaER.Cells(1, HDaER.Columns.Count).End(xlToLeft).Column + 1
'count the number of column on row 1
HDaER.Cells(1, y).Value = EDI.Cells(k, 1).Value
y = HDaER.Cells(2, HDaER.Columns.Count).End(xlToLeft).Column + 1
'count the number of columns on row 2?
HDaER.Cells(2, y).Value = EDI.Cells(k, 2).Value
End If
Next k
Actually, the error you should be getting is 6 - Overflow.
Try this small piece of code:
Sub TestMe()
Dim a As Integer
a = Rows.Count
End Sub
You would get an overflow error, because the Integer is from -32768 to 32767 and the rows in Excel are more than 1 million. The columns are 16384, thus they enough for an integer.
Replace the Integer with Long and try again.
I am writing a macro, which will be used to consolidate data from a range of cells. I have the table with the data that I want to consolidate in sheets("1") in Range D2:J6 and the destination location is again in sheets("1") in M2:R2 (the colums M to R but they contain headers) . I have already written a part of the code below, which applies and runs for them. However, even though it doesnt say it has an error, it just wont run correctly.. I am prividing the screenshot from my excel after the macro runs ..
as you can see from the image, I want to consolidate the duplicate values in row D and print the average of the values located in columns E,F,G, H, I ,J on the same row as the consolidated values in column D. For example for the value "Gebze 6832" in column D, I want to remove it as a duplicate, make it one cell in the destination and print the average of the columns E,F,G, H, I ,J from the two rows that were consolidated next to it in the destination columns.
My code is below (UPDATE)
Dim ws As Worksheet
Dim dataRng As Range
Dim dic As Variant, arr As Variant
Dim cnt As Long
Set ws = Sheets("1")
With ws
lastrow = .Cells(.Rows.Count, "D").End(xlUp).Row 'get last row in Column D
Set dataRng = .Range("D2:D" & lastrow) 'range for Column D
Set dic = CreateObject("Scripting.Dictionary")
arr = dataRng.Value
For i = 1 To UBound(arr)
dic(arr(i, 1)) = dic(arr(i, 1)) + 1
Next
.Range("M2").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.keys) 'uniques data from Column D
.Range("Q2").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.items)
cnt = dic.Count
For i = 2 To cnt + 1
.Range("N" & i & ":P" & i).Formula = "=SUMIF($D$2:$D$" & lastrow & ",$M" & i & ",E$2:E$" & lastrow & ")/" & dic(.Range("M" & i).Value)
.Range("R" & i).Formula = "=IF(INDEX($I$2:$I$" & lastrow & ",MATCH($M" & i & ",$D$2:$D$" & lastrow & ",0))=0,N" & i & ","""")"
.Range("S" & i).Formula = "=IF(INDEX($I$2:$I$" & lastrow & ",MATCH($M" & i & ",$D$2:$D$" & lastrow & ",0))=0,Q" & i & ","""")"
.Range("T" & i).Formula = "=IF($S" & i & ">0,SUMPRODUCT(($D$2:$D$" & lastrow & "=$M" & i & ")*(($J$2:$J$" & lastrow & "-$E$2:$E$" & lastrow & ")>3%)),"""")"
Next i
.Range("M" & i).Value = "Grand Total"
.Range("N" & i & ":P" & i).Formula = "=AVERAGE(N2:N" & cnt + 1 & ")"
.Range("Q" & i).Formula = "=SUM(Q2:Q" & cnt + 1 & ")"
.Range("R" & i).Formula = "=AVERAGE(R2:R" & cnt + 1 & ")"
.Range("S" & i & ":T" & i).Formula = "=SUM(S2:S" & cnt + 1 & ")"
.Range("N2:T" & .Cells(.Rows.Count, "M").End(xlUp).Row + 1).Value = .Range("N2:T" & .Cells(.Rows.Count, "M").End(xlUp).Row + 1).Value
End With
Assuming your data is in range Column D to Column J starting from Row 2 and output has to be displayed from Column M to Column S from Row 2 following might be helpful.
Sub Demo()
Dim ws As Worksheet
Dim dataRng As Range
Dim dic As Variant, arr As Variant
Dim cnt As Long
Set ws = ThisWorkbook.Sheets("Sheet4") 'change Sheet4 to your data sheet
Application.ScreenUpdating = False
With ws
lastRow = .Cells(.Rows.Count, "D").End(xlUp).Row 'get last row in Column D
Set dataRng = .Range("D2:D" & lastRow) 'range for Column D
Set dic = CreateObject("Scripting.Dictionary")
arr = dataRng.Value
For i = 1 To UBound(arr)
dic(arr(i, 1)) = dic(arr(i, 1)) + 1
Next
.Range("M2").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.keys) 'uniques data from Column D
cnt = dic.Count
For i = 2 To cnt + 1
.Range("N" & i & ":S" & i).Formula = "=SUMIF($D$2:$D$" & lastRow & ",$M" & i & ",E$2:E$" & lastRow & ")/" & dic(.Range("M" & i).Value)
Next i
.Range("N2:S" & .Cells(.Rows.Count, "M").End(xlUp).Row).Value = .Range("N2:S" & .Cells(.Rows.Count, "M").End(xlUp).Row).Value
End With
Application.ScreenUpdating = True
End Sub
This code will give following result.
I am working on this code that compares column A ( code source) and column B( code roc) and for each code source in column A it has his code regate in column C and address in column D so if A=B copy them back in E and F with their code regate in column G and their address in column H .
this the code I am using it blocks until I shut down excel and it doesn't give me the exact results if anyone can help me thank you
here is a picture of the result that i need from A and B , C and D
Sub copy_lignes()
Dim DerLigA, DerLigB As Long, i, j As Long
DerLigA = Sheets("sheet3").Range("A" & Rows.Count).End(xlUp).Row
DerLigB = Sheets("sheet3").Range("B" & Rows.Count).End(xlUp).Row
For i = 2 To DerLigA
For j = 2 To DerLigB
If Sheets("sheet3").Range("A" & i) = Sheets("sheet3").Range("B" & j) Then
Sheets("sheet3").Range("A" & i).Copy Destination:=Sheets("sheet3").Range("E" & i)
Sheets("sheet3").Range("B" & i).Copy Destination:=Sheets("sheet3").Range("F" & i)
Sheets("sheet3").Range("C" & i).Copy Destination:=Sheets("sheet3").Range("G" & i)
Sheets("sheet3").Range("D" & i).Copy Destination:=Sheets("sheet3").Range("H" & i)
End If
Next j
Next i
End Sub
Try the code below, maybe this is what you meant in your post:
Sub copy_lignes()
Dim DerLigA, DerLigB As Long, i, j As Long
Dim PasteRow As Long
' optimize speed performance
Application.ScreenUpdating = False
With Sheets("Sheet3")
DerLigA = .Cells(.Rows.Count, "A").End(xlUp).Row
DerLigB = .Cells(.Rows.Count, "B").End(xlUp).Row
PasteRow = 2
For i = 2 To DerLigA
For j = 2 To DerLigB
If .Range("A" & i) = .Range("B" & j) Then
.Range("A" & i).Copy Destination:=.Range("E" & PasteRow)
.Range("B" & j & ":D" & j).Copy Destination:=.Range("F" & PasteRow)
PasteRow = PasteRow + 1
End If
Next j
Next i
End With
' restore settings
Application.ScreenUpdating = True
End Sub
It might be that you just need to tab in a few lines, so it should look like this:
Sub copy_lignes()
Dim DerLigA As Long
Dim DerLigB As Long
Dim i As Integer
Dim j As Integer
i = 2
j = 2
DerLigA = Sheets("sheet3").Range("A" & Rows.Count).End(xlUp).Row
DerLigB = Sheets("sheet3").Range("B" & Rows.Count).End(xlUp).Row
For i To DerLigA
For j To DerLigB
If Sheets("sheet3").Range("A" & i) = Sheets("sheet3").Range("B" & j) Then
Sheets("sheet3").Range("A" & i).Copy Destination:=Sheets("sheet3").Range("E" & i)
Sheets("sheet3").Range("B" & i).Copy Destination:=Sheets("sheet3").Range("F" & i)
Sheets("sheet3").Range("C" & i).Copy Destination:=Sheets("sheet3").Range("G" & i)
Sheets("sheet3").Range("D" & i).Copy Destination:=Sheets("sheet3").Range("H" & i)
End If
Next j
Next i
End Sub
I am receiving this error at the end of a For loop in Excel VBA when collecting data from a website. All the code before is working perfectly.
Even the following code is giving me the result, but it just gives me an error.
y = 5
total = html.getElementsByTagName("table")(3).Children(0).Children.Length
For i = 0 To total
Worksheets("FS Summary").Range("A" & y).Value = html.getElementsByTagName("table")(3).Children(0).Children(i).Children(0).Children(0).innerText
Worksheets("FS Summary").Range("B" & y).Value = html.getElementsByTagName("table")(3).Children(0).Children(i).Children(1).Children(0).innerText
Worksheets("FS Summary").Range("C" & y).Value = html.getElementsByTagName("table")(3).Children(0).Children(i).Children(2).Children(0).innerText
Worksheets("FS Summary").Range("D" & y).Value = html.getElementsByTagName("table")(3).Children(0).Children(i).Children(3).Children(0).innerText
Worksheets("FS Summary").Range("E" & y).Value = html.getElementsByTagName("table")(3).Children(0).Children(i).Children(4).Children(0).innerText
Worksheets("FS Summary").Range("F" & y).Value = html.getElementsByTagName("table")(3).Children(0).Children(i).Children(5).Children(0).innerText
Worksheets("FS Summary").Range("G" & y).Value = html.getElementsByTagName("table")(3).Children(0).Children(i).Children(6).Children(0).innerText
Worksheets("FS Summary").Range("H" & y).Value = html.getElementsByTagName("table")(3).Children(0).Children(i).Children(7).Children(0).innerText
y = y + 1
Next i
Please advise how can I fix it.
If (for example) Children.Length is 5 then your i loop should go from 0 to 4 (ie total - 1) since there is no Children(5)
Also your code would benefit from some simple refactoring:
Dim y, ch, Total, i
y = 5
Set ch = html.getElementsByTagName("table")(3).Children(0).Children
Total = ch.Length
For i = 0 To Total-1
With Worksheets("FS Summary")
.Range("A" & y).Value = ch(i).Children(0).Children(0).innerText
.Range("B" & y).Value = ch(i).Children(1).Children(0).innerText
.Range("C" & y).Value = ch(i).Children(2).Children(0).innerText
.Range("D" & y).Value = ch(i).Children(3).Children(0).innerText
.Range("E" & y).Value = ch(i).Children(4).Children(0).innerText
.Range("F" & y).Value = ch(i).Children(5).Children(0).innerText
.Range("G" & y).Value = ch(i).Children(6).Children(0).innerText
.Range("H" & y).Value = ch(i).Children(7).Children(0).innerText
End With
y = y + 1
Next i
I am looking to see if there is a more efficient way to achieve the result below, so it can be extended if needed.
I'm using this to clean up large spreadsheets that have the rows C-Z blank. I imagine there should be a way to clean it up so that it doesn't have to double in size if I need to clean up a spreadsheet with data from C to AZ.
It's been a while since I used VBA, I found the code below online. (counting ROW B as the spreadsheet in question had an empty ROW A)
Sub delem()
Dim lr As Long, r As Long
lr = Cells(Rows.Count, "B").End(xlUp).Row
For r = lr To 1 Step -1
If Range("C" & r).Value = "" And Range("D" & r).Value = "" And Range("E" & r).Value = "" And Range("F" & r).Value = "" And Range("G" & r).Value = "" And Range("H" & r).Value = "" And Range("I" & r).Value = "" And Range("J" & r).Value = "" And Range("K" & r).Value = "" And Range("L" & r).Value = "" And Range("M" & r).Value = "" And Range("N" & r).Value = "" And Range("O" & r).Value = "" And Range("P" & r).Value = "" And Range("Q" & r).Value = "" And Range("R" & r).Value = "" And Range("S" & r).Value = "" And Range("T" & r).Value = "" And Range("U" & r).Value = "" And Range("V" & r).Value = "" And Range("W" & r).Value = "" And Range("X" & r).Value = "" And Range("Y" & r).Value = "" And Range("Z" & r).Value = "" Then Rows(r).Delete
Next r
End Sub
Thanks!
Just add an inner loop to go through the columns you care about. This will actually run much faster, as VBA doesn't short-circuit the If statement (all of the conditionals are evaluated). But with the loop, you can exit early if you find a value anywhere:
Sub delem()
Dim last As Long
Dim current As Long
Dim col As Long
Dim retain As Boolean
last = Cells(Rows.Count, "B").End(xlUp).Row
For current = last To 1 Step -1
retain = False
For col = 3 To 26
If Cells(current, col).Value <> vbNullString Then
retain = True
Exit For
End If
Next col
If Not retain Then Rows(current).Delete
Next current
End Sub
The Excel worksheet function COUNTA is a clean way to test if a range is empty.
Sub delem()
Dim lr As Long, r As Long
lr = Cells(Rows.Count, "B").End(xlUp).Row
For r = lr To 1 Step -1
'This function Counts the number of cells that are not empty
If WorksheetFunction.CountA(Range(Cells(r, 3), Cells(r, 26)) = 0 Then
Rows(r).Delete
End If
Next r
End Sub