I have data in this format as show in the image
I want the data to be in the format as shown in the image below.
That means i want data from 1991 in image 1 to be pasted to 1991 from image 2, similarly, data from 1992 in image 1 to be pasted to 1992 from image 2.
Instead of copying the data from 1991,1992,1993 manually from image 1 and pasting it in image 2, i want it to be done automatically using programming since I have large amount of data that needs to be managed. Can it be done by using VBA?
Please try this code. Comments in the code will help you make the required adjustments, in particular the name of the worksheet which has your data and the first column to transpose.
Option Explicit
Sub Unpivot()
' 18 Feb 2018
Const WsOutName As String = "Output" ' name the result sheet
Const CaptionRow As Long = 1 ' specifies the row with the captions
' the next row is presumed data
Dim WsIn As Worksheet, WsOut As Worksheet
Dim Rng As Range
Dim Arr() As Variant
Dim Cap As Variant
Dim C As Long, Cl As Long ' column, Last column
Dim R As Long, Rl As Long ' row, Last row
Application.ScreenUpdating = False
On Error Resume Next
Set WsOut = Worksheets(WsOutName)
If Err Then
Set WsOut = Worksheets.Add(Before:=Worksheets(1))
WsOut.Name = WsOutName
Else
WsOut.Cells.ClearContents ' delete all existing content
End If
On Error GoTo 0
Set WsIn = Worksheets("Unpivot") ' change to match
With WsIn
Cl = .Cells(CaptionRow, .Columns.Count).End(xlToLeft).Column
' (2 = B) specifies first column to look at
For C = 2 To Cl
' columns can be of different lengths
Rl = .Cells(.Rows.Count, C).End(xlUp).Row
If Rl > CaptionRow Then
Cap = .Cells(CaptionRow, C).Value
Set Rng = Range(.Cells(CaptionRow + 1, C), .Cells(Rl, C))
Arr = Rng.Value
End If
With WsOut
Rl = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Cells(Rl, 1).Resize(UBound(Arr), 1).Value = Cap
.Cells(Rl, 2).Resize(UBound(Arr), 1).Value = Arr
End With
Next C
End With
Application.ScreenUpdating = True
End Sub
Yes, it could be done by VBA. What you need to do is put all your data in Image 1 into a dictionary. then for the image 2, you can just find the key in the dictionary and paste the result the cell.
PS: You can use Offset to access other cell
Related
I am trying to write a VBA code where I want to populate DATA from a worksheet Range A to AQ spanning over multiple Rows. AQ contains Value "Open" or "Closed". I want to get the rows where AQ value is closed. I tried using the AutoFilter. This is working fine to an extent. But I have to use 2 For loops. One for Each Row and another for Each Column to populate Row wise, column by column into the list box
My Code as follows:
Note : Actual contents start from 6th Row where 6 contains the headers and data starts from 7th Row
Dim i As Long
Dim rowRange As Range
Dim AllData(1 To 1000, 1 To 43) As String
lstRecords.ColumnCount = 43
Set shDSR = mydata1.Sheets("DSR")
last_Row = shDSR.Cells(Rows.Count, 1).End(xlUp).Row
shDSR.AutoFilterMode = False
shDSR.Range("A6:AQ" & last_Row).AutoFilter Field:=43, Criteria1:="CLOSED"
Set rng = shDSR.Range("A6:AQ" & last_Row).SpecialCells(xlCellTypeVisible)
Dim filtrRow() As String
Dim rowCnt As Long
'Me.lstRecords.Clear
rowCnt = 0
If rng.Count > 0 Then
Me.lstRecords.Clear
Me.lstRecords.ColumnCount = rng.Columns.Count
For Each Row In rng.Rows
Me.lstRecords.AddItem
rowCnt = rowCnt +1
filterRow = Range(Row.Address)
'Me.lstRecords.List() = filterRow ''This throws error Type Mismatch so not using
For i = 1 To Row.Columns.Count
AllData(rowCnt, i) = Row.Cells(1, i).Value ''Move to Array
Me.lstRecords.List(rowCnt - 1, i - 1) = filterRow(1, i)'Buggy error when i = 11
Next
Next
'' Following segment works. Add data to Array and then populate ListBox from Array
Me.lstRecords.List() = AllData
Else
MsgBox "No data matches the filter criteria."
End If
Above Code has both approaches
a) Trying to load directly from excel Range (actually using filterRow, but can also directly use range with same issue). But, this approach stops always when i=11 with Invalid property error. I tried changing the data contents etc still same issue
Another Issue when Not taking the array based approach, only one line is added, so in affect only last line is available in the list box
b) Using the AllData array. I load all the row data (matching criteria) into the array and finally populate the listbox from array. THIS WORKS. But I do not like this approach
Can some one please point out where it is going wrong.
Thanks in advance
Problem is that filters create a non contiguous range consisting of areas which you have to iterate separately.
Option Explicit
Sub demo()
Dim mydata1 As Workbook, shDSR As Worksheet
Dim rng As Range, a As Range, r As Range
Dim last_row As Long, n As Long
Dim i As Long, rowCnt As Long
Dim ListData() As String
' change this
Set mydata1 = ThisWorkbook
Set shDSR = mydata1.Sheets("DSR")
With shDSR
.AutoFilterMode = False
last_row = .Cells(.Rows.Count, "AQ").End(xlUp).Row
.Range("A6:AQ" & last_row).AutoFilter Field:=43, Criteria1:="CLOSED"
Set rng = .Range("A6:AQ" & last_row).SpecialCells(xlCellTypeVisible)
.AutoFilterMode = False
End With
' clear listbox
With Me.lstRecords
.Clear
.ColumnCount = rng.Columns.Count
End With
'iterate areas and rows to count visible rows
For Each a In rng.Areas
n = n + a.Rows.Count
Next
rowCnt = 0
If n > 1 Then
' size array
ReDim ListData(1 To n, 1 To rng.Columns.Count)
' fill array
For Each a In rng.Areas
For Each r In a.Rows
rowCnt = rowCnt + 1
For i = 1 To UBound(ListData, 2)
ListData(rowCnt, i) = r.Cells(1, i).Value ''Move to Array
Next
Next
Next
' populate ListBox from Array
Me.lstRecords.List() = ListData
Else
MsgBox "No data matches the filter criteria."
End If
End Sub
Is anyone can help me, pls take a look at the picture i attached.
I want to compare 2 pair of data from 2 different excel file, Station (left file column B) with Station (right file column A) AND Time (left file row 1) with Tendancy (right file Column F).
The left file is the report that im about to finished, the right file is the reference data. If the station and the time data is match each other, it will filled with "1", if not it will stay empty.
The data will start filling from cell C2 until Z32. Im stuck with FOR and IF looping i used. And here's the example:
Cell C2 will filed with "1" bcs there is station 2000001 (cell A2) at 00UTC (cell F2) on the right file.
Cell E2 will stay empty bcs there is station 2000001 BUT NOT at 02UTC on the right file.
Cell C3 will stay empty bcs there is station 2000002 BUT NOT at 00UTC on the right file.
Dim countSM As Long
Dim countSS As Long
Dim countWM As Long
Dim countWS As Long
Dim resultCol As Long
Dim resultRow As Long
Dim lastSM As Long
Dim lastSS As Long
Dim lastWM As Long
Dim lastWS As Long
Dim lastRCol As Long
Dim lastRRow As Long
lastSM = wb1.Sheets("Sheet1").Cells(Rows.count, 1).End(xlUp).Row
lastSS = wb2.Sheets("Worksheet").Cells(Rows.count, 1).End(xlUp).Row
lastWM = wb1.Sheets("Sheet1").Cells(1, Columns.count).End(xlToLeft).Column
lastWS = wb2.Sheets("Worksheet").Cells(Rows.count, 1).End(xlUp).Row
lastRCol = wb1.Sheets("Sheet1").Cells(1, Columns.count).End(xlToLeft).Column
lastRRow = wb1.Sheets("Sheet1").Cells(Rows.count, 1).End(xlUp).Row
For countSM = 2 To lastWM
For countSS = 2 To lastWS
If wb1.Sheets("Sheet1").Cells(countSM, "B") = wb2.Sheets("Worksheet").Cells(countSS, "A") Then
For countWM = 3 To lastWM
For countWS = 2 To lastWS
If wb1.Sheets("Sheet1").Cells(1, countWM) = wb2.Sheets("Worksheet").Cells(countWS, "F") Then
For resultRow = 2 To lastRRow
For resultCol = 3 To lastRCol
wb1.Sheets("Sheet1").Cells(resultRow, resultCol) = "1"
Next resultCol
Next resultRow
Next countSS
ElseIf wb1.Sheets("Sheet1").Cells(1, countWM) <> wb2.Sheets("Worksheet").Cells(countWS, "F") Then
wb1.Sheets("Sheet1").Cells(resultRow, resultCol) = ""
Next countWM
End If
Next countSS
ElseIf wb1.Sheets("Sheet1").Cells(countSM, "B") <> wb2.Sheets("Worksheet").Cells(countSS, "A") Then
wb1.Sheets("Sheet1").Cells(resultRow, resultCol) = ""
Next countSM
End If
I made a code that may work for you. Just count how many rows got the station and UTC value you want to check. If the answer is zero, leave the cell empty. If not, then return 1.
My code is designed on same workbook but it can be adapted yo work with 2 different workbooks easily.
My fake dataset:
My code:
Sub test()
'<------>
'
'
'
'
'YOUR CODE TO OPEN BOTH FILES
'
'
'
'<---->
Dim LeftSheet As Worksheet
Dim RightSheet As Worksheet
Dim MyData As Range 'range to store the data (right file)
Dim LR As Long 'Last row of left file, column Station
Dim LC As Long 'Lastcolumn of left file, (whatever UTC it is)
Dim i As Long
Dim zz As Long
Dim MiF As WorksheetFunction
Set MiF = WorksheetFunction
Dim MyStation As String
Dim MyUTC As String
'Probably you'll need just to adjust references to worksheets from different workbooks
Set LeftSheet = ThisWorkbook.Worksheets("Destiny")
Set RightSheet = ThisWorkbook.Worksheets("Source")
'we store all data into array
Set MyData = RightSheet.Range("A1").CurrentRegion
'data starts at index 2, and we want data from columns 1 and 6 on the range
'Columns 1 and 6 mean columns A and F
'I guess maybe you'll need to adapt this too.
With LeftSheet
LR = .Range("B" & .Rows.Count).End(xlUp).Row
LC = .Cells(1, .Columns.Count).End(xlToLeft).Column
'we count how many rows got the station and tendancy value (intersection) on the right file
' if the count is 0, do nothing. If not zero, return 1 on the cell
'our references will be always at column 2 and row 1
For i = 2 To LR Step 1 'we start at row 2 on left file
MyStation = .Range("B" & i).Value
For zz = 3 To LC Step 1 'we start at column 3, that means column C
MyUTC = .Cells(1, zz).Value
If MiF.CountIfs(MyData.Columns(1), MyStation, MyData.Columns(6), MyUTC) <> 0 Then .Cells(i, zz).Value = 1
Next zz
Next i
End With
'clean variables
Set MyData = Nothing
Set LeftSheet = Nothing
Set RightSheet = Nothing
End Sub
Output after executing code:
Give this solution a try:
Option Explicit
Private Type TWorksheetData
WrkSheet As Worksheet
LastRow As Long
LastColumn As Long
End Type
Sub CopyCompare()
'Organize the variables by referenced worksheet
Dim worksheetData As TWorksheetData
Dim sheet1Data As TWorksheetData
'your solution will provide separate Workbooks for the code below
'ActiveWorkbook (in my case) had both worksheets in order to develop the solution
sheet1Data = SetupWorksheetData(Application.ActiveWorkbook, "Sheet1", sheet1Data)
worksheetData = SetupWorksheetData(Application.ActiveWorkbook, "Worksheet", worksheetData)
Dim refData As Dictionary
Set refData = New Dictionary
'Load the reference data (key = station, value = collection of UTCs)
Dim station As Long
Dim countRow As Long
For countRow = 2 To worksheetData.LastRow
station = CLng(worksheetData.WrkSheet.Range("A" & CStr(countRow)).Value)
If Not refData.Exists(station) Then
refData.Add station, New Collection
End If
refData(station).Add worksheetData.WrkSheet.Range("F" & CStr(countRow)).Value
Next countRow
'Load the UTC header columns from Sheet1
Dim outputMap As Dictionary '(key = UTCXX, value = column Number)
Set outputMap = LoadUTCHeaderColumns(sheet1Data)
'Operate on the Sheet1 data to set the value
For countRow = 2 To sheet1Data.LastRow
station = CLng(sheet1Data.WrkSheet.Range("B" & CStr(countRow)).Value)
Dim utcRef As Variant
If refData.Exists(station) Then
Dim utc As Variant
For Each utc In refData(station)
If InputSheetHasUTCEntry(utc, outputMap) Then
sheet1Data.WrkSheet.Cells(countRow, outputMap(utc)) = "1"
End If
Next
End If
Next countRow
End Sub
Private Function InputSheetHasUTCEntry(ByVal utc As String, ByVal outputMap As Dictionary) As Boolean
InputSheetHasUTCEntry = False
Dim utcRef As Variant
For Each utcRef In outputMap.Keys
If utc = utcRef Then
InputSheetHasUTCEntry = True
Exit Function
End If
Next utcRef
End Function
Private Function LoadUTCHeaderColumns(ByRef sheetData As TWorksheetData) As Dictionary
Set LoadUTCHeaderColumns = New Dictionary
Dim columnHeader As String
Dim outputCol As Long
For outputCol = 1 To sheetData.LastColumn
columnHeader = sheetData.WrkSheet.Cells(1, outputCol).Value
If InStr(columnHeader, "UTC") > 0 Then
LoadUTCHeaderColumns.Add columnHeader, outputCol
End If
Next outputCol
End Function
Private Function SetupWorksheetData(ByVal wb As Workbook, ByVal sheetName As String, ByRef wrksheetData As TWorksheetData) As TWorksheetData
SetupWorksheetData = wrksheetData
Set SetupWorksheetData.WrkSheet = wb.Sheets(sheetName)
SetupWorksheetData.LastRow = SetupWorksheetData.WrkSheet.Cells(Rows.Count, 1).End(xlUp).Row
SetupWorksheetData.LastColumn = SetupWorksheetData.WrkSheet.Cells(1, Columns.Count).End(xlToLeft).Column
End Function
Solution comments:
Loads static reference data from from sheet Worksheet (recommend a different sheet name)
Loads static column number information from Sheet1
There are lots of variables holding similar data for each worksheet used. This indicates an opportunity for using a UserDefinedType (TWorksheetData in this case). This organizes and reduces the number of variables to declare and track.
#1 and #2 uses a Dictionary to retain and correlate static information (requires adding a reference to the Microsoft Scripting Runtime).
Other comments:
(Best Practice) Always declare Option Explicit at the top of modules. Forces all variables used to be declared.
(Best Practice) Don't Repeat Yourself (DRY) - there is a lot of repeated expressions in the original code. This is especially important with Strings. More could be done with the solution provided, but (for example) you will notice that the worksheet name strings only appear once.
I have two sheets, call worksheet1 = GoldCopy and worksheet2 = OPS, both with several of the same columns:
column 1 = Filename, column 3 = file path, column 4 = encryption code, and column 5 = in goldcopy (or OPS depending on which ws you're looking at).
There are 10,000+ rows of data. I want to compare ws1 with ws2 and make sure the filename and encryption code from ws1 is in ws2 (doesn't matter where as long as filename and encryption code are in the same row).
If there is a filename and encryption code that is not in ws2, then that column 5 at that row will be made FALSE.
Then I want to compare ws2 to ws1 with the same logic.
I tried two for loops but it has taken forever to finish. I want to try arrays. I'm having trouble with the 'IF' statements which I will label below.
This is the first part of the code with ws1 checking ws2. I assume to have ws2 check against ws1, it would be the same code, just switched around.
Sub CheckforDiscrepancies
Application.ScreenUpdating = False
Dim s As Worksheet
For Each s In Sheets
'NEW FILE SEARCH A-NAS OPS'
If s.Name = "OPS" Then 'check if there is an OPS file if so then proceed'
ACOL = Worksheets("OPS").Cells(1, Columns.Count).End(xlToLeft).Column
Worksheets("OPS").Cells(1, ACOL + 1).Value = "In Gold Copy?"
'GoldCopy Check with OPS'
Worksheets("GoldCopy").Activate
GCOL = Worksheets("GoldCopy").Cells(1, Columns.Count).End(xlToLeft).Column
Worksheets("GoldCopy").Cells(1, GCOL + 1) = "Deployed in OPS?"
Dim arrayGoldRow As Variant
Dim arrayGoldRow2 As Variant
Dim arrayARow As Variant
Dim arrayARow2 As Variant
arrayGoldRow = Worksheets("GoldCopy").Range("A:A").Value 'this should be column 1 the filename for the goldcopy
arrayARow = Worksheets("OPS").Range("A:A").Value 'this should be column 1 for the filename for the ops sheet
arrayGoldRow2 = Worksheets("GoldCopy").Range("D:D").Value 'this should be column 4 for the encryption code for the goldcopy
arrayARow2 = Worksheets("OPS").Range("D:D").Value 'this should be column 4 for the encryption code for the ops sheet
For i = LBound(arrayGoldRow, 1) To UBound(arrayGoldRow, 1)
GCOL = Worksheets("GoldCopy").Cells(1, Columns.Count).End(xlToLeft).Column
If InStr(Worksheets("GoldCopy").Cells(i, 3), "\sidata\") > 0 Then 'this is checking column 3 to see if the filepath fits a certain criteria
For x = LBound(arrayARow, 1) To UBound(arrayARow, 1) 'not sure if this is correct of not
If Worksheets("GoldCopy").Cells(i,1) = Worksheets("OPS").Cells(j,1) and Worksheets("GoldCopy").Cells(j,4) = Worksheets("OPS").Cells(j,4) Then 'this is saying is filename in column1 and encyrption code in column2 from the goldcopy BOTH match with the filename in column1 and encyrption code in column2 from the ops sheet, then...
bln = True
Worksheets("GoldCopy").Cells(i, GCOL) = bln
Worksheets("GoldCopy").Cells(i, GCOL).Interior.ColorIndex = 10
Exit For
Else
Worksheets("GoldCopy").Cells(i, GCOL) = bln
Worksheets("GoldCopy").Cells(i, GCOL).Interior.ColorIndex = 22
End If
Next x
End If
Next i
This is the way I would tackle the task. Please try my code. It uses the COUNTIFS worksheet function to check if the combination of file and code exists. You could extend this to include the path. It also uses the same function, called with file names reversed, to check availability both ways.
Enum Nws ' worksheet parameters
' 118
NwsFirstDataRow = 2 ' change to suit
NwsFile = 1 ' columns: 1 = column A
NwsPath = 3 ' 3 = column C
NwsCode ' no value assigned means previous + 1
NwsCheck
End Enum
Sub CompareTabs()
' 118
Dim WsOps As Worksheet
Dim WsGold As Worksheet
On Error Resume Next
Set WsOps = Worksheets("OPS")
Set WsGold = Worksheets("GoldCopy")
If Err Then Exit Sub ' exit if one of the sheets doesn't exist
On Error GoTo 0
Application.ScreenUpdating = False
Debug.Print MarkDiscrepancies(WsOps, WsGold)
Debug.Print MarkDiscrepancies(WsGold, WsOps)
Application.ScreenUpdating = False
End Sub
Private Function MarkDiscrepancies(Ws1 As Worksheet, _
Ws2 As Worksheet) As Boolean
' 118
' return True if a discrepancy was found and marked
Dim Src As Variant ' Source = base data
Dim Scode As Variant ' Src encryption codes
Dim Tgt As Range ' Target = range to find Src data in
Dim Tcode As Range ' Tgt encryption codes
Dim R As Long ' loop counter: rows in Ws1
With Ws2
Set Tgt = .Range(.Cells(1, NwsFile), .Cells(.Rows.Count, NwsFile).End(xlUp))
End With
Set Tcode = Tgt.Offset(, NwsCode - NwsFile)
With Ws1
Src = .Range(.Cells(1, NwsFile), .Cells(.Rows.Count, NwsFile).End(xlUp)).Value
Scode = .Range(.Cells(1, NwsFile), .Cells(.Rows.Count, NwsFile).End(xlUp)) _
.Offset(, NwsCode - NwsFile).Value
For R = NwsFirstDataRow To UBound(Src)
On Error Resume Next
.Cells(R, NwsCheck).Value = CBool(WorksheetFunction.CountIfs(Tgt, Src(R, 1), Tcode, Scode(R, 1)))
Next R
MarkDiscrepancies = CBool(WorksheetFunction.CountIf( _
.Range(.Cells(NwsFirstDataRow, NwsCheck), _
.Cells(.Rows.Count, NwsCheck).End(xlUp)), False))
End With
End Function
The function that does the work returns True or False, depending upon whether discrepancies were found. It prints the result to the Immediate Pane. You might show it in a MsgBox or just call the function like a sub (without parentheses) and take your information from column E - as, in fact, does my code.
I have an Excel table which may contain such:
Screenshot of content from a table, columns C and D
It may be much longer
on top of column D may be an empty cell, but after that it is always the same sequence of contents repeating.
I want to copy and paste in another sheet, with transpose, the contents of the neighboring cells, that is in C, so it would look like:
a screenshot from destination table
It is easy to copy the header, but I am completely unable to have the code loop through and copy all the column C contents that appear left to what is between 1tst and 27tst in the original column D, until all of the blocks of data are copied.
To complicate things even further, I want all empty cells in this destination table to take the value from the cell above, basically filling the blanks that way. This would then look like
Final look of the destination table
In this example, the Words "Algeria | DZ" have to be automatically copied down. The cell under "24tst" remains blank as there is nothing but the header preceding this row.
I have absolutely no starting code here, as these data already made a long process from a Word file through a csv using Ruby, and then the csv is read in and reformatted into various sheets in the Excel file with already long line sof code. That all works so far, but these are my missing steps.
Any help is greatly appreciated. I only started coding again 3 weeks ago, after having never programmed in VBA but years ago in perl and R.
-- In response to VBasic2008 and to try that out I made now a test spreadsheet that looks this way:this is closer to what it really looks like
I changed the constants here:
enter code hereConst sName As String = "Tabelle1" ' Source Worksheet Name
enter code hereConst sFirst As String = "C2" ' Source First Cell Address
enter code hereConst tName As String = "Tabelle2" ' Target Worksheet Name
enter code hereConst tFirst As String = "B1" ' Target First Cell Address
The groups will actually be constant in length, actually more than 11, but that can be fixed later.
These:
1tst
2tst
3tst
11tst
4tst
22tst
23tst
24tst
25tst
26tst
27tst -
I pasted this already into target sheet.
What I get from my test using my thus modified solution from VBasic2008 is this:
Afghanistan | AF Åland Islands | AX Albania | AL Algeria | DZ American Samoa | AS Belgium | BE Belize | BZ 24tst Bermuda | BM Bhutan | BT Bolivia | BO
Bonaire, Sint Eustatius and Saba | BQ Bosnia and Herzegovina | BA Botswana | BW Algeria | DZ Brazil | BR Christmas Island | CX Cocos (Keeling) Islands | CC Colombia | CO Comoros | KM n/a Congo | CD
This is almost perfect, except for it should not, in the first row in the target sheet after the headers, copied down the "24tst". Can this still be tweaked?
A Copy Transpose
This will work correctly only if the data is consistent i.e. 11 rows of data and 1 empty (Next-Group) row (can be changed in the constants section) i.e. if you have 5 data sets, there has to be 60 rows of data. If there is 65, only 60 will be processed and if there is 59, only 48 will be processed.
The following image shows what the current setup in the code will produce (without the formatting).
The Code
Option Explicit
Sub transposeData()
Const sName As String = "Sheet1" ' Source Worksheet Name
Const sFirst As String = "A2" ' Source First Cell Address
Const tName As String = "Sheet1" ' Target Worksheet Name
Const tFirst As String = "D1" ' Target First Cell Address
Const NoE As Long = 11 ' Number of Elements
Const NoER As Long = 1 ' Number of Empty Rows
Dim wb As Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
' Define Source Worksheet ('ws').
Dim ws As Worksheet
Set ws = wb.Worksheets(sName)
' Define Source First Cell ('First').
Dim First As Range
Set First = ws.Range(sFirst)
' Define Source Last Cell ('Last').
Dim Last As Range
Set Last = First.Offset(ws.Rows.Count - First.Row, 1).End(xlUp)
If Last.Row - First.Row + 1 < NoE Then
GoTo ProcExit
End If
' Define Source Range ('rng').
Dim rng As Range
Set rng = ws.Range(First, Last)
' Write values from Source Range to Source Array ('Source').
Dim Source As Variant
Source = rng.Value
' Define number of Data Sets ('NoDS').
Dim NoDS As Long
NoDS = Int(UBound(Source, 1) / (NoE + NoER))
' Define Target Number of Rows ('NoR').
Dim NoR As Long
NoR = NoDS + 1
' Define Target Array ('Target').
Dim Target As Variant
ReDim Target(1 To NoR, 1 To NoE)
' Declare additional variables for the upcoming loops.
Dim CurrentValue As Variant ' Source Current Value
Dim CurrentLR As Long ' Source Current Last Row
Dim j As Long ' Target Columns Counter
Dim i As Long ' Target Rows Counter
' Write headers.
For j = 1 To NoE
Target(1, j) = Source(j, 2)
Next j
' Write data.
For i = 2 To NoR
CurrentLR = (i - 2) * (NoE + NoER)
For j = 1 To NoE
CurrentValue = Source(CurrentLR + j, 1)
If Not IsEmpty(CurrentValue) Then
Target(i, j) = CurrentValue
Else
Target(i, j) = Target(i - 1, j)
End If
Next j
Next i
' Define Target Worksheet ('ws').
Set ws = wb.Worksheets(tName)
' Define Target First Cell ('First').
Set First = ws.Range(tFirst)
' Define Target Range ('rng').
Set rng = First.Resize(NoR, NoE)
' Write values from Target Array to Target Range.
rng.Value = Target
' Inform user
MsgBox "Data transferred.", vbInformation, "Success"
ProcExit:
End Sub
EDIT
Tiny Change
Instead of Target(i, j) = Target(i - 1, j) use
If i > 2 Then
Target(i, j) = Target(i - 1, j)
End If
I think the easiest way of doing this is looping through cells with headers and checking each value.
When you find your "next-group" cell then trigger some ifs;
Example program which covers your problem below:
Sub solution()
'Set first row
Dim firstrow As Integer
firstrow = 1
'Find last row
Dim lastrow As Integer
lastrow = Cells(Rows.Count, 1).End(xlUp).Row 'Go to bottom of file and jump up to last non-empty cell
'Set first column
Dim firstcolumn As Integer
firstcolumn = 1
'find last column
Dim lastcolumn As Integer
lastcolumn = 2
'Set first cell of target table
Dim targetrange As Range
Set targetrange = Range("E2")
Dim i As Integer
Dim cnt As Integer 'conuter for creating offset (for columns)
Dim cnt2 As Integer 'conuter for creating offset (for rows)
'Copy headers
cnt = 0
For i = firstrow To lastrow
If Cells(i, lastcolumn).Value = "next-group" Then Exit For
Cells(i, lastcolumn).Copy targetrange.Offset(0, cnt)
cnt = cnt + 1
Next i
'Copy data
cnt = 0
cnt2 = 1
For i = firstrow To lastrow
'If we have text "next group"
If Cells(i, lastcolumn).Value = "next-group" Then
cnt = 0 'start with first column
cnt2 = cnt2 + 1 'Start with next row
'This cell is not copied
Else
'cell is copied
Cells(i, firstcolumn).Copy targetrange.Offset(cnt2, cnt)
'column counter is increased
cnt = cnt + 1
End If
Next i
'Change blank cells in current region into formula which points to cell one row above
'targetrange.CurrentRegion.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
'Same formula but keep cells in first row of data blank istead copying header
Dim targetArea As Range
Set targetArea = targetrange.CurrentRegion
targetArea.Offset(2).Resize(targetArea.Rows.Count - 2).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
End Sub
I didn't cover case when you have empty cell in first row as you didn't described what you're expecting (at this moment it have same formula so it will be filled with header value).
UPDATE: I didnt put "=" inside R1C1 formula, now its fixed.
UPDATE2: Changed part of filling empty cells so it skips first 2 rows (Headers and first row of data) instead filling it as mentioned in question update
I am quite new to VBA so my question may sound silly to some of you.
I have a problem with my code. I am trying to check between 2 sheets(1st: test and 2nd: test data. In the code I am using the code name of the sheets) how may times a criteria/my product is met and based on that number to add that many rows beneath the SKU/product.
What I want to do is, if for my first product/SKU I have stock in 5 different locations, I want to add 5 rows in the first sheet and to see the qty in column D and the location in column E.
TestData tab
The reason why I need to list the quantity in different cells is that the stock is in different locations, so I can not just add in to one cell.
I am also adding screen shots of how my two sheets look like.
I have not add the loop to find the location yet, but I want to understand how to add the rows first.
Sub test()
Dim myrange As Range, testrange As Range, cell As Range, result As Range
Dim i As Long, testlastrow As Long, lastrow As Long
Dim helprng As Range
lastrow = TESTTAB.Range("a" & Rows.Count).End(xlUp).row
testlastrow = TDATA.Range("a" & Rows.Count).End(xlUp).row
Set testrange = TDATA.Range("a2:c" & testlastrow)
Set myrange = TESTTAB.Range("b2:b" & lastrow)
Set result = TESTTAB.Range("d2:e" & testlastrow)
Set helprng = TESTTAB.Range("f2:f" & lastrow)
For Each cell In myrange
For i = 1 To lastrow
If cell.Cells(i, 1) = testrange.Cells(i, 1) Then
result.Cells(i, 1) = testrange.Cells(i, 2)
End If
Next i
Next cell
End Sub
Here is the raw structure you were asking for.
Sub test()
' 011
Dim Rng As Range
Dim Tmp As Variant
Dim Radd As Long ' number of rows to add
Dim R As Long ' row counter
With Tdata
' Range, Cells and Rows Count, all in the same sheet
' exclude caption row(s)
Set Rng = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp))
End With
Application.ScreenUpdating = False ' speed up the process
With TestTab
' end the loop in row 2 because row 1 might contain captions
' loop bottom to top because row numbers will change
' below the current row as you insert rwos
' column 1 = "A"
For R = .Cells(.Rows.Count, 1).End(xlUp).Row To 2 Step -1
Tmp = .Cells(R, 1).Value
Radd = Application.CountIf(Rng, Tmp)
If Radd > 1 Then
.Range(.Rows(R + 1), .Rows(R + Radd)).Insert
.Cells(R + 1, 1).Value = Radd ' for testing purposes
End If
Next R
End With
Application.ScreenUpdating = True ' now you look
End Sub
As our Evil Blue Monkey has suggested, inserting blank rows and then populating them may not be the most efficient way. You can copy a row and then click Insert to insert the copied data into a new row. Get the syntax from the Macro recorder if it's of interest. It works with the Range object the same way.