I can't get this to loop through to the next row. The inner two loops are working fine from what i can tell using the debugger but it never goes to the next row. Any help would be appreciated.
Sub PopulateData()
Dim s1 As Worksheet
Dim s2 As Worksheet
Dim locationRow As Integer
Set s1 = ThisWorkbook.Sheets("Order_LVL")
Set s2 = ThisWorkbook.Sheets("sheet1")
Dim Lastrow As Integer
Lastrow = s1.Cells(Rows.Count, 1).End(xlUp).Row
Dim iRow As Integer
For iRow = 1 To Lastrow
Dim cellj As Range
For Each cellj In s1.Range("B:F")
locationRow = 1
Dim celli As Range
For Each celli In s2.Range("B1:F1")
Dim currentrow As Long
currentrow = iRow + 1
If s1.Cells(currentrow, cellj.Column).Value = 0 Then
ElseIf s1.Cells(currentrow, cellj.Column).Value <> s2.Cells(locationRow, celli.Column).Value And s2.Cells(currentrow, celli.Column).Value = 0 Then
s2.Cells(currentrow, celli.Column).Value = 0
Else: s2.Cells(currentrow, celli.Column).Value = 1 'indicates that this order features a line from this location
End If
Next celli
Next cellj
Next iRow
End Sub
Can you try this on some test data (Note I haven't tested it myself but re-written it with only two loops)
Sub PopulateData()
Dim s1 As Worksheet: Dim s2 As Worksheet
Dim rng As range: Dim rng2 As range
Dim cell: Dim header
With Application
.ScreenUpdating = False
End With
With ThisWorkbook
Set s1 = .Sheets("Order_LVL")
Set s2 = .Sheets("sheet1")
End With
With s1
Set rng = range(.Cells(1, 2), .Cells(.Cells(Rows.Count, 6).End(xlUp).Row, 6)) ' Used Range in Order_LVL
End With
Set rng2 = range(s2.Cells(1, 2), s2.Cells(1, 6)) 'Header range in sheet1
For Each cell In rng.Cells
For Each header In rng2.Cells
If cell.value = 0 Then
ElseIf cell.value <> header.value And s2.Cells(cell.Row, header.Column).value = 0 Then
s2.Cells(cell.Row, header.Column).value = 0 ' Not sure why you're doing this - if it is already 0 why set it back to 0. Left it in for continuity
Else
s2.Cells(cell.Row, header.Column).value = 1 ' indicates that this order features a line from this location
End If
Next header
Next cell
With Application
.ScreenUpdating = True
End With
End Sub
It should do what you want if I've understood correctly.
Related
I have this table:
Quantity Name
1 A
3 C1
3 C2
4 D
I'm trying to make this table change to:
Quantity Name
1 A
1 A
3 C1
3 C1
3 C1
3 C2
3 C2
3 C2
4 D
4 D
4 D
4 D
But the result is not as expect: Result
Pls help my solve this problem.
Thanks!
Here is my code:
Sub newrow()
Dim xRg As Range
Dim xAddress As String
Dim I, xNum, xLastRow, xFstRow, xCol, xCount As Long
On Error Resume Next
xAddress = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("Select a range to use(single column):", "KuTools For Excel", xAddress, , , , , 8)
If xRg Is Nothing Then Exit Sub
Application.ScreenUpdating = False
xLastRow = xRg(1).End(xlDown).Row
xFstRow = xRg.Row
xCol = xRg.Column
xCount = xRg.Count
Set xRg = xRg(1)
For I = xLastRow To xFstRow Step -1
xNum = Cells(I, xCol)
If IsNumeric(xNum) And xNum > 0 Then
Rows(I + 1).Resize(Cells(I, xCol) - Cells(I - 1, xCol)).Insert
xCount = xCount + xNum
End If
Next
xRg.Resize(xCount, 1).Select
Application.ScreenUpdating = True
End Sub
First of all …
If you Dim xFstRow, xCol, xCount As Long then only xCount is of type Long all the others are of type Variant. You need to specify a type for every variable!
Dim xFstRow As Long, xCol As Long, xCount As Long
Don't ever use On Error Resume Next without proper error handling. This only hides error messages but the errors still occur you just cannot see them. Therefore you cannot debug/fix your code. Remove it completely or implement a complete error handling instead.
You need to copy the row before you insert, otherwise you just insert empty rows.
I suggest the following code:
Option Explicit
Public Sub AddRowsFromQantities()
Dim SelAddress As String
SelAddress = ActiveWindow.RangeSelection.Address
Dim SelRange As Range
Set SelRange = Application.InputBox("Select a range to use(single column):", "KuTools For Excel", SelAddress, , , , , 8)
Dim fRow As Long
fRow = SelRange.Row 'first row of selected rang
Dim lRow As Long
lRow = fRow + SelRange.Rows.Count - 1 'last row of selected range
'find last used row within the selected range
If Cells(Rows.Count, 1).End(xlUp).Row < lRow Then
lRow = Cells(Rows.Count, 1).End(xlUp).Row
End If
Application.ScreenUpdating = False
Dim iRow As Long
For iRow = lRow To fRow Step -1
If IsNumeric(Cells(iRow, 1)) Then
Dim Quantity As Long
Quantity = Cells(iRow, 1).Value
If Quantity > 1 Then
Rows(iRow).Copy
Rows(iRow).Resize(RowSize:=Quantity - 1).Insert
End If
End If
Next iRow
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
I have the following VBA code for excel
Dim k As Integer, z As Integer
Dim sourceSht As Worksheet
Dim destSht As Worksheet
z = 0
Set sourceSht = Sheets("sheet1")
Set destSht = Sheets("sheet2")
DoEvents
For k = 1 To 5000
If k < 3 Or (k - 1) Mod 3 <> 0 Then
z = z + 1
sourceSht.Columns(k).Copy destSht.Columns(z)
End If
Next
This code was working perfectly for rows (changed this part"sourceSht.Columns(k).Copy destSht.Columns(z)").
but I can not make it work for columns. I want excel to copy the first 2 columns then skip the third one, then copy 2 again, skip one and etc... can somebody help me and explain what am I doing wrong?
I'm going to ignore the use of mod and do a Step 3 with the loop:
Dim i as Long, j as Long
For i = 1 to 5000 Step 3
With sourceSht
If j = 0 Then
j = 1
Else
j = j + 2 'Copying 2 columns over, so adding 2 each time
End If
.Range(.Columns(i),.Columns(i+1)).Copy destSht.Range( destSht.Columns(j), destSht.Column(j+1))
End With
Next i
Something like that should do it for you
Alternate:
Sub tgr()
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim rCopy As Range
Dim rLast As Range
Dim LastCol As Long
Dim i As Long
Set wsSource = ActiveWorkbook.Sheets("Sheet1")
Set wsDest = ActiveWorkbook.Sheets("Sheet2")
On Error Resume Next
Set rLast = wsSource.Cells.Find("*", wsSource.Range("A1"), xlFormulas, , xlByColumns, xlPrevious)
On Error GoTo 0
If rLast Is Nothing Then Exit Sub 'No data
LastCol = rLast.Column
Set rCopy = wsSource.Range("A:B")
For i = 4 To LastCol Step 3
Set rCopy = Union(rCopy, wsSource.Columns(i).Resize(, 2))
Next i
rCopy.Copy wsDest.Range("A1")
End Sub
Try this (use count for the number of time you need to copy columns, t for the first columns you need to copy):
Sub copy_columns()
t = 1
Count = 1
Do Until Count = 10
Range(Columns(t), Columns(t + 1)).Copy
Cells(1, t + 3).Select
Selection.PasteSpecial Paste:=xlPasteValues
t = t + 3
Count = Count + 1
Loop
End Sub
I'm using a VBA to copy all the unique values from one sheet to another sheet. My VBA looks like this:
Sub UniqueListSample()
Application.ScreenUpdating = False
Dim lastrow As Long
Dim i As Long
Dim dictionary As Object
Set dictionary = CreateObject("scripting.dictionary")
Set shee = ThisWorkbook.Sheets("Sheet1")
lastrow = shee.Cells(Rows.Count, "B").End(xlUp).Row
On Error Resume Next
For i = 1 To lastrow
If Len(Sheet1.Cells(i, "B")) <> 0 Then
dictionary.Add shee.Cells(i, "B").Value, 1
End If
Next
Sheet3.Range("A3").Resize(dictionary.Count).Value = _
Application.Transpose(dictionary.keys)
Application.ScreenUpdating = True
End Sub
This takes all the unique values from Sheet 1 column B and moves them to sheet 3 column A. What I'm now trying to add is a function that takes the same rows from column C in sheet 1 and paste them into sheet 3 column B.
Is there an easy way to add this to the existing VBA?
please check this:
Option Explicit
Sub UniqueListSample()
Application.ScreenUpdating = False
Dim lastrow As Long
Dim i As Long
Dim dictionary As Object
Dim shee As Worksheet
Set dictionary = CreateObject("scripting.dictionary")
Set shee = ThisWorkbook.Sheets("Sheet1")
lastrow = shee.Cells(Rows.Count, "B").End(xlUp).Row
On Error Resume Next
For i = 1 To lastrow
If Len(Sheet1.Cells(i, "B")) <> 0 Then
dictionary.Add shee.Cells(i, "B").Value, shee.Cells(i, "c").Value
End If
Next
With Sheet3
.Range("A3").Resize(dictionary.Count).Value = _
Application.Transpose(dictionary.keys)
For i = 1 To dictionary.Count
.Cells(i + 2, 2) = dictionary(Sheet3.Cells(i + 2, 1).Value)
Next
End With
Application.ScreenUpdating = True
End Sub
If you just want one column you can utilise the Item. I prefer to avoid the "On Error" statement - the method below will not error if the same key is used (it will just overwrite).
Sub UniqueListSample()
Application.ScreenUpdating = False
Dim lastrow As Long
Dim i As Long
Dim dictionary As Object
Dim shee As Worksheet
Set dictionary = CreateObject("scripting.dictionary")
Set shee = ThisWorkbook.Sheets("Sheet1")
lastrow = shee.Cells(Rows.Count, "B").End(xlUp).Row
With dictionary
For i = 1 To lastrow
If Len(Sheet1.Cells(i, "B")) <> 0 Then
If Not (.Exists(shee.Cells(i, "B").Value)) Then
.Item(shee.Cells(i, "B").Value) = shee.Cells(i, "C").Value
End If
End If
Next
Sheet3.Range("A3").Resize(.Count).Value = Application.Transpose(.keys)
Sheet3.Range("B3").Resize(.Count).Value = Application.Transpose(.items)
End With
Application.ScreenUpdating = True
End Sub
I have an issue which I use a lot of manual time on currently.
I have following simple data:
And I wish to convert all the accounts downwards with the name next to the accounts in another column. Currently I do this by using the 'text to columns' function and then manually copy the names down.. HARD work.. :)
This is an example of my wish scenario..
Hope you are able to help..
Thanks a lot
Kristoffer
The following short macro will take data from Sheet1 and output records in Sheet2:
Sub DataReorganizer()
Dim i As Long, j As Long, N As Long
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")
N = s1.Cells(Rows.Count, "A").End(xlUp).Row
j = 1
For i = 2 To N
v1 = s1.Cells(i, 1)
ary = Split(s1.Cells(i, 2), ";")
For Each a In ary
s2.Cells(j, 1).Value = v1
s2.Cells(j, 2).Value = a
j = j + 1
Next a
Next i
End Sub
Input:
and output:
Try this
Option Explicit
Sub Test()
Dim rng As Excel.Range
Set rng = ThisWorkbook.Worksheets.Item(1).Cells(1, 1).CurrentRegion
Set rng = rng.Offset(1)
Set rng = rng.Resize(rng.Rows.Count - 1)
Dim vPaste
Dim lTotalRows As Long
Dim lPass As Long
For lPass = 0 To 1
Dim rowLoop As Excel.Range
For Each rowLoop In rng.Rows
Dim sName As String
sName = rowLoop.Cells(1, 1)
Dim sAccounts As String
sAccounts = rowLoop.Cells(1, 2)
Dim vSplitAccounts As Variant
vSplitAccounts = VBA.Split(sAccounts, ";")
If lPass = 0 Then
lTotalRows = lTotalRows + UBound(vSplitAccounts) + 1
Else
Dim vLoop As Variant
For Each vLoop In vSplitAccounts
lTotalRows = lTotalRows + 1
vPaste(lTotalRows, 1) = sName
vPaste(lTotalRows, 2) = vLoop
Next vLoop
End If
Next
If lPass = 0 Then
ReDim vPaste(1 To lTotalRows, 1 To 2)
lTotalRows = 0
End If
Next
ThisWorkbook.Worksheets.Item(2).Cells(1, 1).Value = "Name"
ThisWorkbook.Worksheets.Item(2).Cells(1, 2).Value = "Account"
Dim rngPaste As Excel.Range
Set rngPaste = ThisWorkbook.Worksheets.Item(2).Cells(2, 1).Resize(lTotalRows, 2)
rngPaste.Value2 = vPaste
End Sub
I have code here which loops through a list of files; opening them, extracting data and moving it into the main workbook. What i am looking to do get it so the data for abel is in columns c and d but then put varo in f and g etc. the problem that i see is that the placement code is inside the loop so for each i it will just write over the previous line instead of being in a different column all together!
Sub Source_Data()
Dim r
Dim findValues() As String
Dim Wrbk As Workbook
Dim This As Workbook
Dim sht As Worksheet
Dim i
Dim tmp
Dim counter
Dim c As Range
Dim firstAddress
Dim rng As Range
ReDim findValues(1 To 3)
findValues(1) = "abel"
findValues(2) = "varo"
findValues(3) = "Tiger"
counter = 0
r = Range("A1").End(xlDown).Row
Set rng = Range(Cells(1, 1), Cells(r, 1))
Set This = ThisWorkbook
For Each tmp In rng
Workbooks.Open tmp
Set Wrbk = ActiveWorkbook
Set sht = ActiveSheet
For i = 1 To 3
With sht.Range(Cells(1, 1), Range("A1").SpecialCells(xlCellTypeLastCell))
Set c = .Find(findValues(i), LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Offset(0, 2).Value
Do
This.Activate
tmp.Offset(0, 2).Value = tmp.Value
tmp.Offset(0, 3).Value = firstAddress
Set c = .FindNext(c)
counter = counter + 1
Loop While Not c Is Nothing And c.Value = firstAddress
End If
End With
Wrbk.Activate
Next
Wrbk.Close
Next tmp
End Sub
**EDIT:**I know it can be done by adding a multiplier of "i" to the offset value but this makes things bigger than they need to be if i wish to search for 50 keywords
Here is my answer, hope to help you, and as always, if you need an improvement, just tell me.
Sub Source_Data()
Dim r
Dim findValues() As String
Dim Wrbk As Workbook
Dim This As Workbook
Dim sht As Worksheet
Dim i
Dim tmp
Dim counter
Dim c As Range
Dim firstAddress
Dim rng As Range
Dim ColNum 'the columns number var
ReDim findValues(1 To 3)
findValues(1) = "abel"
findValues(2) = "varo"
findValues(3) = "Tiger"
counter = 0
r = Range("A1").End(xlDown).Row
Set rng = Range(Cells(1, 1), Cells(r, 1))
Set This = ThisWorkbook
For Each tmp In rng
Workbooks.Open tmp
Set Wrbk = ActiveWorkbook
Set sht = ActiveSheet
For i = 1 To 3
With sht.Range(Cells(1, 1), Range("A1").SpecialCells(xlCellTypeLastCell))
Set c = .Find(findValues(i), LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Offset(0, 2).Value
Do
This.Activate
Select Case i 'Test var i (the value)
Case "abel" 'in case the value (that is a string) is equal to...
ColNum = 1 'set the var, with the number of the column you want
Case "varo" 'in case the value...
ColNum = 2 'Set the column...
Case "Tiger"
ColNum = 3
Case Else 'In case that the i var not match with anyvalue take this column number
ColNum = 20 'the garbage!
End Select
tmp.Offset(0, ColNum).Value = tmp.Value 'Put the value in the selected columns
tmp.Offset(0, ColNum + 1).Value = firstAddress 'and put the value to the next column of the
'selected column
Set c = .FindNext(c)
counter = counter + 1
Loop While Not c Is Nothing And c.Value = firstAddress
End If
End With
Wrbk.Activate
Next
Wrbk.Close
Next tmp
End Sub
Note:
You need to set the ColNum var to the values that you need, put there the numbers of the columns you really need to store the value of i and the next line is to put the address of the i var
You can just change these two lines:
tmp.Offset(0, 2).Value = tmp.Value
tmp.Offset(0, 3).Value = firstAddress
To this
tmp.Offset(0, 2 + (i-1)*2).Value = tmp.Value
tmp.Offset(0, 3 + (i-1)*2).Value = firstAddress