Thank you in advance for looking in to this!
I have an issue with a code. What I am trying to do is for the macro in Excel to compare two columns with numbers in two sheets and then based on conditions that the row will also have a string value copy the number that is missing in to the main sheet (I hope it makes sense).
Sub conditionalCopying()
inactiveRow = Worksheets("Inactive").Cells(Rows.Count, 1).End(xlUp).Row
cutRow = Worksheets("Cutting").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To inactiveRow
If Worksheets("Inactive").Cells(i, 3).Value = "North" Then
For x = 2 To cutRow
If Worksheets("Inactive").Cells(i, 1) <> Worksheets("Cutting").Cells(x, 1).Value Then
Worksheets("Inactive").Rows(i).Copy
Worksheets("Cutting").Activate
b = Worksheets("Cutting").Cells(cutRow + 1, 1).Select
ActiveSheet.Paste
Worksheets("Inactive").Activate
End If
Next i
Next x
End Sub
Can't include screenshots due to reputation not being high enough, sorry.
Thank you once again for your help.
Maybe give this a try :
Sub conditionalCopying()
Dim Cpt As Long
inactiveRow = Worksheets("Inactive").Cells(Rows.Count, 1).End(xlUp).Row
Cutrow = Worksheets("Cutting").Cells(Rows.Count, 1).End(xlUp).Row
Cpt = Cutrow
For i = 2 To inactiveRow
If Worksheets("Inactive").Cells(i, 3).Value = "North" Then
For x = 2 To Cutrow
If Worksheets("Inactive").Cells(i, 1) <> Worksheets("Cutting").Cells(x, 1).Value Then
Cpt = Cpt + 1
Worksheets("Inactive").Rows(i).Copy
Worksheets("Cutting").Activate
b = Worksheets("Cutting").Cells(Cpt, 1).Select
ActiveSheet.Paste
Worksheets("Inactive").Activate
GoTo nexti
End If
Next x
End If
nexti:
Next i
End Sub
Edited Code Give this a try
Sub conditionalCopying()
Dim Cpt As Long
inactiveRow = Worksheets("Inactive").Cells(Rows.Count, 1).End(xlUp).Row
Cutrow = Worksheets("Cutting").Cells(Rows.Count, 1).End(xlUp).Row
Cpt = Cutrow
For i = 2 To inactiveRow
If Worksheets("Inactive").Cells(i, 3).Value = "North" And Worksheets("Inactive").Cells(i, 1).Value = "11" Then
Cpt = Cpt + 1
Worksheets("Inactive").Rows(i).Copy
Worksheets("Cutting").Activate
b = Worksheets("Cutting").Cells(Cpt, 1).Select
ActiveSheet.Paste
Worksheets("Inactive").Activate
End If
Next i
ThisWorkbook.Sheets("cutting").Range("A1:D" & Cpt).RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlYes
End Sub
Second Edit
Sub conditionalCopying()
Dim Cpt As Long
inactiveRow = Worksheets("Inactive").Cells(Rows.Count, 1).End(xlUp).Row
Cutrow = Worksheets("Cutting").Cells(Rows.Count, 1).End(xlUp).Row
Cpt = Cutrow
For i = 2 To inactiveRow
If Worksheets("Inactive").Cells(i, 3).Value = "North" Then
Cpt = Cpt + 1
Worksheets("Inactive").Rows(i).Copy
Worksheets("Cutting").Activate
b = Worksheets("Cutting").Cells(Cpt, 1).Select
ActiveSheet.Paste
Worksheets("Inactive").Activate
End If
Next i
ThisWorkbook.Sheets("cutting").Range("A1:D" & Cpt).RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlYes
End Sub
Related
I have a column of data in excel which could potentially have data over 2000 rows. In that data there is groups of data that I would like to send to the top of a new column every time a new group is found. I've looked at the special paste option for transpose along with using a delimiter but i can only move data one column over and not to the top. I'm looking for a solution which is fast due to the amount of data that would need to be split into new columns. I appreciate the help.
Below is a table of how the data looks.
Below is how I would like the data to look
Try this simple code,
Sub splitRange()
Dim i As Long, j As Long, k As Long
Cells(1, 6) = Cells(1, 1)
Cells(1, 7) = Cells(1, 2)
j = 1
k = 6
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i, 1) = Cells(i - 1, 1) Then
j = j + 1
Cells(j, k) = Cells(i, 1)
Cells(j, k + 1) = Cells(i, 2)
Else
k = k + 3
j = 1
Cells(j, k) = Cells(i, 1)
Cells(j, k + 1) = Cells(i, 2)
End If
Next i
End Sub
Modify the code if you want the output in a separate sheet. I would like you to google it to learn about it.
I had to do something similar. You can try also this code:
Sub Move_Data()
Application.ScreenUpdating = False
Dim r As Integer
Dim StartRow As Integer
Dim EndRow As Integer
Dim ColA As Integer
Dim vLastRow As Integer
Dim vEnd As Integer
r = 1
StartRow = 1
EndRow = 1
ColA = 4
vEnd = 1
vLastRow = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
Do Until Cells(r, 1) <> Cells(StartRow, 1)
DoEvents
r = r + 1
Loop
vEnd = r
Do Until r > vLastRow
DoEvents
StartRow = r
Do Until Cells(r, 1) <> Cells(StartRow, 1)
DoEvents
r = r + 1
Loop
EndRow = r - 1
Range(Cells(StartRow, 1), Cells(EndRow, 2)).Select
Selection.Copy
Cells(1, ColA).Select
ActiveSheet.Paste
ColA = ColA + 3
Loop
r = vEnd + 1
Range(Cells(vEnd, 1), Cells(vLastRow, 2)).ClearContents
Cells(1, 1).Select
Application.ScreenUpdating = True
MsgBox "Done"
End Sub
I'm learning VBA and have some problems
What I have is a list of date:
picture1
What I want to do is add 3 meals for everyday like this
picture2
I have recorded a macro which can achieve this:
Sub InsertMeal()
ActiveCell.EntireRow.Insert
ActiveCell.EntireRow.Insert
ActiveCell.Offset(0, 2).Select
ActiveCell.FormulaR1C1 = "Breakfast"
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "Lunch"
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "Dinner"
ActiveCell.Offset(-2, -2).Range("A1:A3").Select
Selection.Merge
End Sub
Now I want write a macro, which apply this InsertMeal() function to each cells in selected range.
This is what I wrote
Sub ApplyToAll()
For Each c In ActiveCell.CurrentRegion.Cells
Call InsertMeal
ActiveCell.Offset(1, 0).Select
Next
End Sub
The problem is, since I insert rows every time, the For loop doesn't work well. The loop never end. Now I don't know how to "keep the range" to make the loop work.
Please help if you know how to do this. Thank you, really appreciate.
There really is no need for two functions here. To amend your loop to do what you need, b/c you are adding rows, you will need to nest a small loop inside the other loop that works in you block of 3 ,Breakfast ,Lunch, and Dinner.
The code would look something like this, but you will have to amend the range to suit your purpose. For example
Sub dave()
Dim i As Long
Dim lastrow As Long
Dim j As Long
lastrow = Cells(Rows.Count, 1).End(xlUp).Row * 3
x = Array("Breakfast", "Lunch", "Dinner")
For i = 1 To lastrow
Cells(i + 1, 1).Resize(2).EntireRow.Insert
For j = 1 To 3
Cells(i + j - 1, 3).Value = x(j - 1)
Next j
Cells(i, 1).Resize(3).Merge: i = i + 2
Next i
End Sub
BTW, the lastrow will need to be multiplied by 3 as you are addeding rows, so the original lastrow will not reflect the actuall last row when finnished.
Sub RelativeFunc()
col = ActiveCell.Column
lastrow = Cells(Rows.Count, col).End(xlUp).Row
firstrow = Cells(1, col).End(xlDown).Row
rownum = lastrow - firstrow + 1
frownum = rownum * 3
x = Array("Breakfast", "Lunch", "Dinner")
For i = 1 To frownum
Cells(i + firstrow, col).Resize(2).EntireRow.Insert
For j = 1 To 3
Cells(firstrow + i - 1 + j - 1, col + 1).Value = x(j - 1)
Next j
Cells(firstrow + i - 1, col).Resize(3).Merge
i = i + 2
Next i
End Sub
I have 4 columns on Sheet1 and 4 on Sheet2
I have named the columnson sheet 1 as:
MvarNo = 1
Mdesc = 2
Mfile = 3
Mfield = 4
where 1 = a etc....
How do I name these columns with the sheet name and column number?
Thanks
UPDATE
Sub Compare()
MvarNo = 1 'Sheet1
Mdesc = 2 'Sheet1
Mfile = 3 'Sheet1
Mfield = 4 'Sheet1
XvarNo = 6 'Sheet1
Xdesc = 7 'Sheet1
Xfile = 8 'Sheet1
Xfield = 9 'Sheet1
CvarNo = 1 'Sheet2
Cdesc = 2 'Sheet2
Cfile = 3 'Sheet2
Cfield = 4 'Sheet2
'Count rows on Master Sheet (Sheet1)
MvarNoLastRow = Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
MdesclastRow = Worksheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Row
MfilelastRow = Worksheets("Sheet1").Cells(Rows.Count, "C").End(xlUp).Row
MfieldlastRow = Worksheets("Sheet1").Cells(Rows.Count, "D").End(xlUp).Row
'Count rows on Compare Sheet (Sheet2)
CvarNoLastRow = Worksheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row
CdesclastRow = Worksheets("Sheet2").Cells(Rows.Count, "B").End(xlUp).Row
CfilelastRow = Worksheets("Sheet2").Cells(Rows.Count, "C").End(xlUp).Row
CfieldlastRow = Worksheets("Sheet2").Cells(Rows.Count, "D").End(xlUp).Row
For i = 2 To MvarNoLastRow
For j = 2 To CvarNoLastRow
If Cells(i, MvarNo) = Cells(j, CvarNo) Then
Cells(i, XvarNo).Value = "Yes"
' If Cells(i, MvarNo) = Cells(j, CvarNo) And Cells(i, Mdesc) = Cells(j, Cdesc) And Cells(i, Mfile) = Cells(j, Cfile) And Cells(i, Mfield) = Cells(j, Cfield) Then
' Cells(i, XvarNo).Value = "Yes"
' ElseIf Cells(i, MvarNo) <> Cells(j, CvarNo) And Cells(i, Mdesc) <> Cells(j, Cdesc) And Cells(i, Mfile) <> Cells(j, Cfile) And Cells(i, Mfield) <> Cells(j, Cfield) Then
j = j + 1
ElseIf j = CvarNoLastRow Then
Cells(i, XvarNo).Value = "No"
End If
Next j
Next i
End Sub
the reason for this macro is to compare information between sheet 1 and sheet2.
I 'think' from my code it is actually just comparing the data on sheet 1 with sheet1.
Does this work?
Here my sheet is called "Ad revenues"
Sub test()
Dim lC As Long
Dim strColNames(1 To 4) As String
For lC = 1 To 4
strColNames(lC) = Sheet1.Name & vbTab & Str(Cells(1, lC).Column)
Next lC End Sub
End Sub()
If you need to get the sheet name, all of the following will work:
=SUBSTITUTE(CELL("filename"),LEFT(CELL("filename"),FIND("]",CELL("filename"))),"")
=RIGHT(CELL("filename"),LEN(CELL("filename"))-FIND("]",CELL("filename")))
=MID(CELL("filename"),FIND("]",CELL("filename"))+1,31)
The latter works because excel limits you to 31 characters when naming a sheet
To get the name of a column, you can use something like below:
=SUBSTITUTE(MID(ADDRESS(1,CELL("col")),2,2),"$","")
=MID(SUBSTITUTE(ADDRESS(1,COLUMN(R31)),"$1",""),2,2)
I have worked with basic pivot tables for a few years, however I am getting stuck on something that I think should be fairly simple to solve (ugh).
I would like to format my pivot table in a specific way.
For example, just say I am using the following data:
Client Name Stage Amount Paid Date Paid
Client A Start $70,000 1/10/2015
Client A Middle $50,000 1/11/2015
Client A End $30,000 1/12/2015
Client B Start $50,000 5/11/2015
Client B Middle $30,000 5/11/2015
Client B End $50,000 5/12/2015
Client C Start $10,000 10/12/2015
Client C Middle $20,000 20/12/2015
Client C End $30,000 30/12/2015
I would like to arrange the pivot table so that it looks like this:
Table Example with Correct Formatting
The only way I can almost get it to work is if it looks like this:
PivotTable Example - Not correct formatting
I really need the formatting to be exactly like picture one.
Thanks for any help you may be able to provide.
Answers in excel steps or in VBA code would be awesome :)
I think you cannot have exactly the output that you want with a pivote table. So i wrote a code which create first a pivot table as close as you want. And then other macro which will create the exact format table as you put in the picture.
1) However you have (it could be easily automated) to replace in your row data:
Start by 1
Middle by 2
End by 3
And your row data tittles should be in Sheet1 and start cell A1
Main sub to call all codes: (all codes have to be in the same module. How hope it can help you.
Sub main()
Call PivotTable
Call FinalTable
Call DeleteRow
Call FormatTable
End Sub
Here is the first code that create the pivot table:
Sub PivotTable()
Dim PTCache As PivotCache
Dim PT As PivotTable
'1.CREATE DATA STORAGE UNIT
Set PTCache = ActiveWorkbook.PivotCaches.Create( _
SourceType:=xlDatabase, _
SourceData:=Range("A1").CurrentRegion)
'2. ADD WORKSHEET
Worksheets.Add
ActiveSheet.Name = "PivotTable1"
'3.CREATE PIVOT TABLE N*1
Set PT = ActiveSheet.PivotTables.Add( _
PivotCache:=PTCache, _
TableDestination:=Range("A3"))
'4. ENUMERATE PREFERENCES FOR PIVOTE TABLE
With PT
.PivotFields("Client Name").Orientation = xlRowField
.PivotFields("Amount Paid").Orientation = xlRowField
.RowAxisLayout xlTabularRow
End With
'MODIFYING DATA FIELD CALCULATION
With PT.PivotFields("Client Name")
.Subtotals(1) = False
End With
With PT.PivotFields("Date Paid")
.Orientation = xlColumnField
.Caption = " Date Paid"
End With
With PT.PivotFields("Stage")
.Orientation = xlDataField
.Caption = " Stage"
.NumberFormat = "[=1]""Start"";[>2]""End"";""Middle"""
End With
With PT.PivotFields("Amount Paid")
.Orientation = xlDataField
.Function = xlSum
.Caption = " Amount Paid"
End With
Range("C4").Select
Selection.Group Start:=True, End:=True, Periods:=Array(False, False, False, _
False, True, False, False)
PT.DisplayErrorString = False
PT.HasAutoFormat = False
PT.PivotSelect "", xlDataAndLabel, True
Selection.Copy
Worksheets.Add
ActiveSheet.Name = "FinalTable"
Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
Rows(1).Delete
Columns("B").Delete
Columns("I").Delete
Columns("H").Delete
End Sub
To format:
Sub FinalTable()
Dim Nextcell As Double
Dim j As Integer
Lastrow = Sheets("FinalTable").Range("A1").SpecialCells(xlCellTypeLastCell).Row
i = 3
Do Until i = Lastrow
NextProcess i, Nextcell, Lastrow, j
For c = 2 To 7
If j = Lastrow Then Exit Do
If IsEmpty(Cells(i, c)) Then
For j = Nextcell - 1 To i Step -1
If Not IsEmpty(Cells(j, c)) And Not IsEmpty(Cells(j - 1, c)) Then
Range(Cells(j, c), Cells(j - 1, c)).Copy Cells(i, c)
Range(Cells(j, c), Cells(j - 1, c)).ClearContents
Exit For
End If
If Not IsEmpty(Cells(j, c)) Then
Cells(j, c).Copy Cells(i, c)
Cells(j, c).ClearContents
Exit For
End If
If Not IsEmpty(Cells(j - 1, c)) Then
Cells(j - 1, c).Copy Cells(i, c)
Cells(j - 1, c).ClearContents
Exit For
End If
Next j
End If
Next c
StepB = Nextcell - i
i = StepB + i
Loop
i = 2
Do
If Application.WorksheetFunction.CountA(Rows(i)) = 0 Then
Rows(i).Delete
i = i - 1
End If
Lastrow = Sheets("FinalTable").Range("A" & Rows.Count).End(xlUp).Row
i = 1 + i
Loop Until i = Lastrow
End Sub
Code to delete the empty rows in your Final Table
Sub DeleteRow()
Dim Lastrow As Long
Dim i As Integer
Lastrow = Sheets("FinalTable").Range("A" & Rows.Count).End(xlUp).Row
i = 2
Do
If Application.WorksheetFunction.CountA(Rows(i)) = 0 Then
Rows(i).Delete
i = i - 1
End If
Lastrow = Sheets("FinalTable").Range("A" & Rows.Count).End(xlUp).Row
i = 1 + i
Loop Until i = Lastrow
End Sub
Code to put border in your final table:
Sub FormatTable()
Dim Nextcell As Double
Dim j As Integer
Lastrow = Sheets("FinalTable").Range("G" & Rows.Count).End(xlUp).Row
For i = 2 To Lastrow
If Not IsEmpty(Cells(i, 1)) Then
If Not IsEmpty(Cells(i + 1, 1)) Then
Range(Cells(i, 1), Cells(i, 7)).BorderAround
ElseIf Not IsEmpty(Cells(i + 2, 1)) Then
NextProcess i, Nextcell, Lastrow, j
Range(Cells(i, 1), Cells(Nextcell - 1, 7)).BorderAround
Else
Range(Cells(i, 1), Cells(Lastrow, 7)).BorderAround
End If
End If
Range(Cells(1, 2), Cells(Lastrow, 3)).BorderAround
Range(Cells(1, 4), Cells(Lastrow, 5)).BorderAround
Range(Cells(1, 6), Cells(Lastrow, 7)).BorderAround
Next i
End Sub
The subroutine to find the next client name:
Sub NextProcess(ByVal i As Integer, ByRef Nextcell As Double, ByVal Lastrow As Long, ByRef j As Integer)
Dim Found As Boolean
'Dim j As Integer
Found = False
j = i + 1
Do Until Found = True Or Lastrow = j
If Not IsEmpty(Range("A" & j).Value) Then
Nextcell = Cells(j, 1).Row
Found = True
End If
j = j + 1
Loop
End Sub
I am adapting off of the question: Re-Arranging the row data in columns
I have Excel data set up as follows;
Collection LatDD LonDD Date Location Method Specie1 Specie2 Specie3(+-110 species columns in total)
ABS1 11.35 -10.3 2003-02-01 A Bucket 0 1 3
ABS2 11.36 -10.4 2003-02-02 B Stick 2 0 6
I would Like This Data to appear like so:
Collection Specie Count LatDD LonDD Date Location Method
ABS1 Specie1 11.35 -10.3 2003-02-01 A Bucket
ABS1 Specie2 1 11.35 -10.3 2003-02-01 A Bucket
ABS1 Specie3 3 11.35 -10.3 2003-02-01 A Bucket
ABS2 Specie1 2 11.36 -10.4 2003-02-02 B Stick
ABS2 Specie2 -11.36 -10.4 2003-02-02 B Stick
ABS2 Specie3 6 -11.36 -10.4 2003-02-02 B Stick
I attempted to adapt Ripsters original VBA code answer but unfortunately i was unable to figure how i would need to change it. Could someone please advise me on how to adjust his code to produce the desired output?
Here is his orginal vba code:
Sub Example()
Dim Resources() As String
Dim rng As Range
Dim row As Long
Dim col As Long
Dim x As Long
ReDim Resources(1 To (ActiveSheet.UsedRange.Rows.Count - 1) * (ActiveSheet.UsedRange.Columns.Count - 1), 1 To 3)
'Change this to the source sheet
Sheets("Sheet1").Select
'Read data into an array
For row = 2 To ActiveSheet.UsedRange.Rows.Count
For col = 2 To ActiveSheet.UsedRange.Columns.Count
x = x + 1
Resources(x, 1) = Cells(row, 1).Value ' Get name
Resources(x, 2) = Cells(1, col).Value ' Get date
Resources(x, 3) = Cells(row, col).Value ' Get value
Next
Next
'Change this to the destination sheet
Sheets("Sheet2").Select
'Write data to sheet
Range(Cells(1, 1), Cells(UBound(Resources), UBound(Resources, 2))).Value = Resources
'Insert column headers
Rows(1).Insert
Range("A1:C1").Value = Array("Resource", "Date", "Value")
'Set strings to values
Set rng = Range(Cells(1, 3), Cells(ActiveSheet.UsedRange.Rows.Count, 3))
rng.Value = rng.Value
End Sub
Try this:
Sub Example()
Dim row As Long
Dim col As Long
Dim x As Long
h1 = "Sheet1"
h2 = "Sheet2"
Sheets(h1).Select
x = 2
'Headers Sheet2
Sheets(h2).Cells(1, 1).Value = Sheets(h1).Cells(1, 1)
Sheets(h2).Cells(1, 2).Value = "Specie"
Sheets(h2).Cells(1, 3).Value = "Count"
Sheets(h2).Cells(1, 4).Value = Sheets(h1).Cells(1, 2)
Sheets(h2).Cells(1, 5).Value = Sheets(h1).Cells(1, 3)
Sheets(h2).Cells(1, 6).Value = Sheets(h1).Cells(1, 4)
Sheets(h2).Cells(1, 7).Value = Sheets(h1).Cells(1, 5)
Sheets(h2).Cells(1, 8).Value = Sheets(h1).Cells(1, 6)
For row = 2 To ActiveSheet.UsedRange.Rows.Count
For col = 7 To ActiveSheet.UsedRange.Columns.Count
Sheets(h2).Cells(x, 1).Value = Sheets(h1).Cells(row, 1).Value
Sheets(h2).Cells(x, 2).Value = Sheets(h1).Cells(1, col).Value
Sheets(h2).Cells(x, 3).Value = Sheets(h1).Cells(row, col).Value
Sheets(h2).Cells(x, 4).Value = Sheets(h1).Cells(row, 2).Value
Sheets(h2).Cells(x, 5).Value = Sheets(h1).Cells(row, 3).Value
Sheets(h2).Cells(x, 6).Value = Sheets(h1).Cells(row, 4).Value
Sheets(h2).Cells(x, 7).Value = Sheets(h1).Cells(row, 5).Value
Sheets(h2).Cells(x, 8).Value = Sheets(h1).Cells(row, 6).Value
x = x + 1
Next
Next
End Sub
Sheet1:
Sheet2:
A short versión:
Sub Example()
Dim row As Long
Dim col As Long
Dim x As Long
Set Sh1 = ThisWorkbook.Worksheets("Sheet1")
Set Sh2 = ThisWorkbook.Worksheets("Sheet2")
Sh1.Select
'Headers Sheet2
Sh2.Cells(1, 1).Value = Sh1.Cells(1, 1)
Sh2.Cells(1, 2).Value = "Specie"
Sh2.Cells(1, 3).Value = "Count"
For i = 4 To 8
Sh2.Cells(1, i).Value = Sh1.Cells(1, i - 2)
Next
x = 2 'Starting row of sheet2.
For row = 2 To ActiveSheet.UsedRange.Rows.Count
For col = 7 To ActiveSheet.UsedRange.Columns.Count
Sh2.Cells(x, 1).Value = Sh1.Cells(row, 1).Value
Sh2.Cells(x, 2).Value = Sh1.Cells(1, col).Value
Sh2.Cells(x, 3).Value = Sh1.Cells(row, col).Value
For i = 4 To 8
Sh2.Cells(x, i).Value = Sh1.Cells(row, i - 2).Value
Next
x = x + 1
Next
Next
Sh2.Select
End Sub
another idea....
Your source data is in "Sheet1", starting at "A1", no empty values neither in Column A, nor in Row 1.
If you run the code, you will get the re-sorted table in "Sheet2" ( I omitted headers, though - too lazy....)
Hope this helps
Sub sort_new()
Dim col_no As Long, row_no As Long
Dim i As Long, j As Long, k As Long
Dim arr_DB As Variant, arr_new As Variant
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
ws1.Activate
row_no = ws1.Range(Cells(Rows.Count, 1), Cells(Rows.Count, 1)).End(xlUp).Row
col_no = ws1.Range(Cells(1, Columns.Count), Cells(1, Columns.Count)).End(xlToLeft).Column
arr_DB = ws1.Range(Cells(1, 1), Cells(row_no, col_no))
ReDim arr_new(1 To (row_no - 1) * (col_no - 6), 1 To 8)
For i = 2 To row_no
For j = 7 To col_no
k = k + 1
arr_new(k, 1) = arr_DB(i, 1) 'Collection
arr_new(k, 4) = arr_DB(i, 2) 'LatDD
arr_new(k, 5) = arr_DB(i, 3) 'LonDD
arr_new(k, 6) = arr_DB(i, 4) 'Date
arr_new(k, 7) = arr_DB(i, 5) 'Location
arr_new(k, 8) = arr_DB(i, 6) 'Method
arr_new(k, 2) = arr_DB(1, j) 'Each Specie(j) Column
arr_new(k, 3) = arr_DB(i, j) 'Each Specie(j) Column
Next
Next
ws2.Activate
ws2.Range(Cells(2, 1), Cells((row_no - 1) * (col_no - 6) + 1, 8)) = arr_new
End Sub