is there any simple way to swap the data in the form of series as attached 1 to attached 2
you can use simple loops:
Sub swapper()
Dim n As Integer
Dim r As Range 'destination row
Dim s As Range 'source
Dim a As Range 'source row
Set s = Range("A12:C14")
Set r = Range("A17")
For Each a In s.Rows
For n = a.Cells(1, 2).value To a.Cells(1, 3).value
r.value = a.Cells(1, 1).value
r.offset(0, 1).value = n
Set r = r.offset(1, 0)
Next
Next
End Sub
Use pivot tables, can be very helpful for these types of data.
Related
I've got a price list [Data] with up to a thousand multiple items from numerous suppliers. These are output regularly from a database to be sorted (by supplier) for easy updating of pricing and other assorted tasks.
The search criteria are selected from a list box created from the [Data].
This is then to be matched to all the line items in the [Data] and a [Catalogue] created, returning multiple cells from each line. A lot of cells on each row need to be ignored in order to re-enter the system correctly.
I've got it creating a list so far however, the matching starts at the first supplier item and continues to the end of the list, as though it doesn't match the items following after that first initial match.
It needs to pick out only the data from the selected supplier and return the required results.
The raw data is not sorted by supplier, and I am hoping to be able to do this without doing a data sort first. But even with a data sort, it runs to the end of the list.
Private Sub SupplierData_Click()
ListBoxValue = SupplierData.Text
Sheets("Catalogue").Cells(2, 27).Value = ListBoxValue
Unload Me
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim oCell As range
Dim Match As range
Dim i As Long
Dim j As Long
i = 2
j = 0
Set ws1 = ThisWorkbook.Sheets("Catalogue")
Set ws2 = ThisWorkbook.Sheets("Data")
Set Match = ws1.Cells(2, 27)
Do While ws2.Cells(i, 1).Value <> ""
Set oCell = ws2.range("A:A").Find(What:=Match)
If Not oCell Is Nothing Then ws1.Cells(i, 2) = oCell.Offset(j, 0)
If Not oCell Is Nothing Then ws1.Cells(i, 3) = oCell.Offset(j, 1)
If Not oCell Is Nothing Then ws1.Cells(i, 4) = oCell.Offset(j, 9)
i = i + 1
j = j + 1
Loop
End Sub
Solved.
Went a different route.
Private Sub SupplierData_Click()
ListBoxValue = SupplierData.Text
Sheets("Catalogue").Cells(2, 27).Value = ListBoxValue
Unload Me
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim oCell As range
Dim opt3 as range
Set ws1 = ThisWorkbook.Sheets("Catalogue")
Set ws2 = ThisWorkbook.Sheets("Data")
Set opt3 = ws1.Cells(1, 29)
oCell = 2
While Len(ws2.range("A" & CStr(oCell)).Value) > 0
If ws2.Cells(oCell, 1).Value = opt3 Then
ws1.Cells(oCell, 2).Value = ws2.Cells(oCell, 1)
ws1.Cells(oCell, 4).Value = ws2.Cells(oCell, 2) & " " & ws2.Cells(oCell, 8) & " " & ws2.Cells(oCell, 4)
ws1.Cells(oCell, 5).Value = ws2.Cells(oCell, 3)
ws1.Cells(oCell, 6).Value = ws2.Cells(oCell, 10)
oCell = oCell + 1
Wend
End Sub
I am trying to compare two Range and copy data based on IF and AND condition, but AND condition is not working as a result data is being copied only based on IF condition. Please suggest what change should I make in code. Below is Code which I am currently using:
Sub Copy3()
Dim mCell As Range
Dim yRange As Range
Dim mRange As Range
Dim RRange As Range
Set mRange = Worksheets("Sheet2").Range("DB2:DB17")
Set yRange = Worksheets("Sheet2").Range("CZ2:CZ17")
Set RRange = Worksheets("Sheet2").Range("CY2:CY17")
Set target = mRange.Offset(columnoffset:=-3)
Dim P As Long, Q As Long, t As Long
For P = 1 To mRange.Cells.Count
For Q = 1 To RRange.Cells.Count
For t = 1 To yRange.Cells.Count
If mRange.Cells(P).Value <> "" And RRange.Cells(Q).Value <> yRange.Cells(t).Value Then
mRange.Cells(P).Copy target.Cells(P)
End If
Next
Next
Next
End Sub
you can try this (the sheet name and ranges must be changed to reflect the structure of your data). I made the assumption that target points to column A. The address of the cells is traced to make it easier to check if this is in deed what you expect the code to do.
Dim wholeRange As Range
Set wholeRange = Worksheets("Feuil1").Range("A2:D17")
If (Not wholeRange Is Nothing) Then
Dim row As Range, rP As Range, rQ As Range, rR As Range, rT As Range
For Each row In wholeRange.Rows
Set rP = row.Offset(0, 1).Resize(1, 1)
Set rR = row.Offset(0, 2).Resize(1, 1)
Set rQ = row.Offset(0, 3).Resize(1, 1)
Set rT = row.Offset(0, 0).Resize(1, 1)
Debug.Print "P:" + rP.Address + " R:" + rR.Address + " Q:" + rQ.Address + " T:" + rT.Address
If (rP.Cells(1, 1).Value <> "") And (rQ.Cells(1, 1).Value <> rT.Cells(1, 1).Value) Then
rP.Cells(1, 1).Value = rT.Cells(1, 1).Value
End If
Next row
Else
Debug.Print "wholeRange range is not defined"
End If
All-
I'm very new to VBA and I really need help. I have a worksheet called Sheet 1 that looks like this (This is where the data will be copied from)
and another sheet (Sheet2) that looks like this (this is where the data will be copied to). Notice that the order is not the same as above
When a user types in a place such as "Paris" I want it to copy all corresponding values with "Paris" and it's associated rows. So the end result should look like this
Here is the code I have so far. Right now I can pull all the corresponding values based on the Users input, but I cannot for the life of me figure out how to get the associated rows. Please help! Any input will be highly appreciated.
Dim x As String
Dim K As Long
Dim ct As Variant
Dim r As Range
Dim w1 As Worksheet
Dim w2 As Worksheet
Set w1 = Sheets("Sheet1")
Set w2 = Sheets("Sheet2")
a = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
x = Application.InputBox("Please Enter Place")
w1.Activate
K = 3
For Each r In Intersect(Range("C3:C3" & a), ActiveSheet.UsedRange)
ct = r.Value
If InStr(ct, x) > 0 And ct <> "" Then
r.Copy w2.Cells(K, 1)
K = K + 1
w2.Activate
End If
Next r
End Sub
Assign the entire range to an array for quicker looping, then once the array finds a match to your inputstring, rewrite the values to your 2nd sheet.
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet, wsArr()
set ws1 = thisworkbook.worksheets("Sheet1")
set ws2 = thisworkbook.worksheets("Sheet2")
With ws1
wsArr = .Range(.Cells(3, 1), .Cells(LastRow(ws1), 4)).Value
End With
Dim findStr As String
findStr = InputBox("Please Enter Place")
Dim i As Long, r as long
Application.ScreenUpdating = False
With ws2
.Range("A3:D3").Value = array("Place", "Name", "Thing", "Animal")
For i = LBound(wsArr) To UBound(wsArr)
If wsArr(i, 3) = findStr Then
r = LastRow(ws2) + 1
.Cells(r, 1) = wsArr(i, 3)
.Cells(r, 2) = wsArr(i, 1)
.Cells(r, 3) = wsArr(i, 2)
.Cells(r, 4) = wsArr(i, 4)
End If
Next
End With
Application.ScreenUpdating = True
End Sub
Function LastRow(ByVal ws As Worksheet, Optional ByVal col As Variant = 1) As Long
With ws
LastRow = .Cells(.Rows.Count, col).End(xlUp).Row
End With
End Function
For even better performance, consider doing a COUNTIF() to get the count of the number of findStr occurances in your range - that way you can use this value to ReDim a new array in order to write the matches there, then write the array to Sheet2 all at once.
So I have multiple sets of 3 columns. Each set is always in the same column order ("SKU", "Sales". "Date".)
I am wondering is there is a VBA script or other method that would do the following:
1.) Copy G:I
2.) Paste into A:C
3.) Copy J:L
4.) Paste into A:C (Underneath G:I's data)
5.) Copy M:O
6.) Paste into A:C (underneath J:L's data)
7.) Repeat (I would like it to repeat every 3 columns forever, but if that's not possible I'll manually input the columns if I have
to.)
This is a visual of what I'm looking for: http://i.imgur.com/AagLIm8.png
I also uploaded the workbook in case you need it for reference: https://www.dropbox.com/s/wea2nr4xbfo4934/Workbook.xlsx?dl=0
Thanks for the help!
The code below does what you want, and I've included some ".select" lines to help you understand. I suggest you step through it to become clear, as in the animated gif. Then, remove all the ".select" lines of code.
Option Explicit
Sub moveData()
Dim rSource As Range, rDest As Range, r As Range
Dim tbl As Range, rowNum As Integer
Const colNum = 3
Set rDest = Range("A1")
Set rSource = Range("G1")
Set r = rSource
While r <> ""
Set r = Range(r, r.End(xlDown))
Set tbl = Range(r, r.Offset(0, colNum - 1))
tbl.Select
Set tbl = Range(tbl, tbl.End(xlDown).Offset(1, 0))
tbl.Select
tbl.Copy
rDest.Select
rDest.PasteSpecial (xlPasteAll)
Set rDest = rDest.Offset(tbl.Rows.Count, 0)
Set r = r(1, 1)
r.Select
Set r = r.Offset(0, colNum)
r.Select
Wend
End Sub
try to do this:
Sub CopyColumns()
Dim actualRow As Integer
Dim actualColumn As Integer
Dim rowFrom As Integer
Dim myColumns As Integer
Dim startColumn As Integer
myColumns = 3 'the number of columns before start repeating (in your case is SKU, Sales, Date, so there are 3 columns)
startColumn = 7 'the column where start de data. In your example is the Column G
actualRow = 1
actualColumn = 1
rowFrom = 1
Dim eoRows As Boolean
eoRows = False
While eoRows = False
'verify if there's no more data
If Cells(rowFrom, startColumn) = "" Then
eoRows = True
Else
'verify if there's no more row
While Cells(rowFrom, startColumn) <> ""
For i = startColumn To startColumn + myColumns - 1
Cells(actualRow, actualColumn) = Cells(rowFrom, i)
actualColumn = actualColumn + 1
Next
rowFrom = rowFrom + 1
actualRow = actualRow + 1
actualColumn = 1
Wend
rowFrom = 1
startColumn = startColumn + myColumns
End If
Wend
End Sub
I am trying to make edge relation from excel file which are organized in rows,
A,B,C,
D,E
the aim is to create relationships from each row:
A,B
A,C
B,C
I have the following codes , the problem is the codes is efficient when rows are equal in length but for example for above rows it create also following edges (relationship):
D," "
E, " "
Which create big problem for large data set. I was wondering if some body can help me to adjust the code the way to create the edge list only till filled cells in each row. If there is any other way to do this more efficient will appreciate it.
Thank you so much,Will be great help.
My code:
Sub Transform()
Dim targetRowNumber As Long
targetRowNumber = Selection.Rows(Selection.Rows.Count).Row + 2
Dim col1 As Variant
Dim cell As Range
Dim colCounter As Long
Dim colCounter2 As Long
Dim sourceRow As Range: For Each sourceRow In Selection.Rows
For colCounter = 1 To Selection.Columns.Count - 1
col1 = sourceRow.Cells(colCounter).Value
For colCounter2 = colCounter + 1 To Selection.Columns.Count
Set cell = sourceRow.Cells(, colCounter2)
If Not cell.Column = Selection.Column Then
Selection.Worksheet.Cells(targetRowNumber, 1) = col1
Selection.Worksheet.Cells(targetRowNumber, 2) = cell.Value
targetRowNumber = targetRowNumber + 1
End If
Next colCounter2
Next colCounter
Next sourceRow
End Sub
I've played around with it - this should do the trick. We can probably speed it up by outputting to another variant array if needed, but this ran pretty quickly for me:
Sub Transform_New()
Dim rngSource As Range, rngDest As Range
Dim varArray As Variant
Dim i As Integer, j As Integer, k As Integer
Set rngSource = Sheet1.Range("A1", Sheet1.Cells(WorksheetFunction.CountA(Sheet1.Columns(1)), 1)) 'Put all used rows into range
Set rngDest = Sheet1.Cells(WorksheetFunction.CountA(Sheet1.Columns(1)), 1).Offset(2, 0) 'Set target range to start 2 below source range
varArray = Range(rngSource, rngSource.Offset(0, Range("A1").SpecialCells(xlCellTypeLastCell).Column)).Value
For i = LBound(varArray, 1) To UBound(varArray, 1) 'Loop vertically through array
For j = LBound(varArray, 2) To UBound(varArray, 2) 'Loop horizontally through each line apart from last cell
k = j
Do Until varArray(i, k) = ""
k = k + 1
If varArray(i, k) <> "" Then
rngDest.Value = varArray(i, j)
rngDest.Offset(0, 1).Value = varArray(i, k)
Set rngDest = rngDest.Offset(1, 0)
End If
Loop
Next
Next
End Sub