Copy and Paste a table to main sheet from another sheet using - excel

I have a dashboard and I would like to have a main sheet that summarize some name that I want to search for, so all my data are in other sheets.
I am trying to copy and past a table from data sheet to the main sheet. I´ve tried using =Vlookup and =xlookup, but it didn't wor. Now I am trying to use VBA.
First of all the data sheet is:
Data sheet
I would like to copy and past data from I3:M6 (data sheet) if what I am searching for is "name1" in main sheet. On the other hand, if I want to search for "name2" I need to copy I9:M12 (data sheet) and so on.
the table 2 on main sheet nee just the data from the data sheet:
main sheet
With that in mind, I´ve tried to create a VBA:
Sub table()
Dim i As Long, j as long
Dim wsMain As Worksheet, wsRV2 As Worksheet
Set wsMain = ThisWorkbook.Worksheets("main")
Set wsRV2 = ThisWorkbook.Worksheets("rv")
For i = 2 To 250 Step 6 'loop in increments of 15
For j = 9 To 10 Step 1
If wsRV2.Cells(i, 8) = wsMain.Cells(4, 3) Then
wsMain.Cells(12, 28) = wsRV2.Cells(i + 1, j)
wsMain.Cells(12, 29) = wsRV2.Cells(i + 1, j + 1)
wsMain.Cells(12, 30) = wsRV2.Cells(i + 1, j + 2)
wsMain.Cells(12, 31) = wsRV2.Cells(i + 1, j + 3)
wsMain.Cells(12, 32) = wsRV2.Cells(i + 1, j + 4)
wsMain.Cells(13, 28) = wsRV2.Cells(i + 2, j)
wsMain.Cells(13, 29) = wsRV2.Cells(i + 2, j + 1)
wsMain.Cells(13, 30) = wsRV2.Cells(i + 2, j + 2)
wsMain.Cells(13, 31) = wsRV2.Cells(i + 2, j + 3)
wsMain.Cells(13, 32) = wsRV2.Cells(i + 2, j + 4)
wsMain.Cells(14, 28) = wsRV2.Cells(i + 3, j)
wsMain.Cells(14, 29) = wsRV2.Cells(i + 3, j + 1)
wsMain.Cells(14, 30) = wsRV2.Cells(i + 3, j + 2)
wsMain.Cells(14, 31) = wsRV2.Cells(i + 3, j + 3)
wsMain.Cells(14, 32) = wsRV2.Cells(i + 3, j + 4)
wsMain.Cells(15, 28) = wsRV2.Cells(i + 4, j)
wsMain.Cells(15, 29) = wsRV2.Cells(i + 4, j + 1)
wsMain.Cells(15, 30) = wsRV2.Cells(i + 4, j + 2)
wsMain.Cells(15, 31) = wsRV2.Cells(i + 4, j + 3)
wsMain.Cells(15, 32) = wsRV2.Cells(i + 4, j + 4)
End If
Next j
Next i
end sub
i = line and j = column
If wsRV2.Cells(i, 8) = wsMain.Cells(4, 3) Then -->> if name1, name 2 ... is the same for both sheets
I know it is not the best way to do it by far (and it is not working). What am I doing wrong? If there´s a way to do it using excel function instead using vba I would like to know as well. I accept both solutions. Thank you so muchhh!

Related

Use IFERROR, INDEX, MATCH if the amount of column is limited

I would like to know if it would be possible to use the IFERROR, INDEX, MATCH function on below scenario.
D2:=INDEX($A$2:$A$16, MATCH(0, COUNTIF($D$1:$D1, $A$2:$A$16), 0))
E2: =IFERROR(INDEX($B$2:$B$16, MATCH(0, COUNTIF($D2:D2,$B$2:$B$16)+IF($A$2:$A$16<>$D2, 1, 0), 0)), "")
H2: =IFERROR(INDEX($C$2:$C$16, MATCH(0, COUNTIF($D2:D2,$C$2:$C$16)+IF($A$2:$A$16<>$D2, 1, 0), 0)), "")
I2: =IFERROR(INDEX($C$2:$C$16, MATCH(0, COUNTIF($D2:H2,$C$2:$C$16)+IF($A$2:$A$16<>$D2, 1, 0), 0)), "")
Based on the data of Countries and Cities filled in yellow on the left, by using the IFERROR, INDEX, MATCH formula I managed to get all the data I need. Now if there are more than 3 City, I want for the excel to continue the list of cities by creating another row under it as example of row filled in red.
I hope it makes sence. Let me know if it's possible.

You did tag vba as well as excel-formula so give this a try
Sub condense()
Dim src, dest(), ws As Worksheet, srcRange As Range, i As Long, j As Long, countryCount As Long, rowNum As Long
Set ws = ActiveSheet
Set srcRange = ws.Cells(1, 1).Resize(ws.Cells(ws.Rows.Count, 1).End(xlUp).Row, 3)
src = srcRange.Value2
ReDim dest(1 To UBound(src, 1) - 1, 1 To 7)
rowNum = 1
i = 2
Do While i <= UBound(src, 1)
countryCount = Application.CountIf(srcRange.Columns(1), src(i, 1))
For j = 1 To countryCount
dest(rowNum + Int((j - 1) / 3), 1) = src(i + j - 1, 1)
dest(rowNum + Int((j - 1) / 3), 2 + ((j - 1) Mod 3)) = src(i + j - 1, 2)
dest(rowNum + Int((j - 1) / 3), 5 + ((j - 1) Mod 3)) = src(i + j - 1, 3)
Next j
i = i + countryCount
rowNum = rowNum + 1 + Int((countryCount - 1) / 3)
Loop
ws.Cells(2, 4).Resize(rowNum, 7).Value2 = dest
With ws.Cells(1, 4).Resize(1, 7)
.Value2 = Strings.Split("Country,City1,City2,City3,Image1,Image2,Image3", ",")
.EntireColumn.AutoFit
End With
End Sub
EDIT 17-Jul-2022 (per comment from OP)
Sub condenseInto4cols()
Dim src, dest(), ws As Worksheet, srcRange As Range, i As Long, j As Long, countryCount As Long, rowNum As Long
Set ws = ActiveSheet
Set srcRange = ws.Cells(1, 1).Resize(ws.Cells(ws.Rows.Count, 1).End(xlUp).Row, 3)
srcRange.Sort key1:=ws.Cells(2, 1), order1:=xlAscending, Header:=xlYes
src = srcRange.Value2
ReDim dest(1 To UBound(src, 1) - 1, 1 To 9)
rowNum = 1
i = 2
Do While i <= UBound(src, 1)
countryCount = Application.CountIf(srcRange.Columns(1), src(i, 1))
For j = 1 To countryCount
dest(rowNum + Int((j - 1) / 4), 1) = src(i + j - 1, 1)
dest(rowNum + Int((j - 1) / 4), 2 + ((j - 1) Mod 4)) = src(i + j - 1, 2)
dest(rowNum + Int((j - 1) / 4), 6 + ((j - 1) Mod 4)) = src(i + j - 1, 3)
Next j
i = i + countryCount
rowNum = rowNum + 1 + Int((countryCount - 1) / 4)
Loop
ws.Cells(2, 4).Resize(rowNum, 9).Value2 = dest
With ws.Cells(1, 4).Resize(1, 9)
.Value2 = Strings.Split("Country,City1,City2,City3,City4,Image1,Image2,Image3,Image4", ",")
.EntireColumn.AutoFit
End With
srcRange.Sort key1:=ws.Cells(2, 2), order1:=xlAscending, Header:=xlYes
End Sub

Reading data from a sheet

I have two sheets. When the second is activated I need to read the first and insert info into the second.
The code below should do this but it is reading the second sheet,"Cabinet install", instead of the first. What is wrong?
Dim k As Integer
Dim j As Integer
Dim Sumknobs As Integer
Dim Cabsht As Worksheet
Dim Installsht As Worksheet
Set Cabsht = Worksheets("Cabinets")
Set Installsht = Worksheets("Cabinet Install")
Application.ScreenUpdating = True
Cabsht.Activate
With Worksheets("Cabinets")
For j = 1 To 4
For k = 1 To 46
Sumknobs = Sumknobs + .Cells(k + 4, 5 * j - 2) * Cells(k + 4, 5 * j - 1)
Next k
Next j
For j = 1 To 2
For k = 1 To 71
Sumknobs = Sumknobs + .Cells(k + 4, 5 * j + 18) * Cells(k + 4, 5 * j + 19)
Next k
Next j
End With
Installsht.Cells(17, 6) = Sumknobs

You are missing some . 's
Replace:
Sumknobs = Sumknobs + .Cells(k + 4, 5 * j - 2) * Cells(k + 4, 5 * j - 1)
with:
Sumknobs = Sumknobs + .Cells(k + 4, 5 * j - 2) * .Cells(k + 4, 5 * j - 1)
same for the second loop-set.

How can i optimize this macro?

I have a portfolio report I build from VBA code on monthly and ad-hoc basis. It works fine today, but the underlying VBA is far from optimized. The code sniplet below is repeated 5 times as there are 5 projects in the system now, but it will grow to 50 shortly. Is there anyone that have suggestions as to how I can utilize VBA more elegantly performing the copying to the locations specified in the code (see sniplet below)
Sub CreatePortFolio()
Application.ScreenUpdating = False
'Clears old data
Application.Goto Reference:="PFData" 'Named range in the portfolio overview sheet
Selection.ClearContents
'************* Project 1
If Not Sheets(Sheets.Count).Range("BG1").Value = "" Then
Ark4.Range("B5").Value = Sheets(Sheets.Count).Range("BG1").Value 'Ark4 is the portfolio report and the sheets.count is used to pick the latest import of data - always in the same format
Ark4.Range("C5").Value = Sheets(Sheets.Count).Range("BF1").Value
Ark4.Range("D5").Value = Sheets(Sheets.Count).Range("BH1").Value
Ark4.Range("E5").Value = Sheets(Sheets.Count).Range("AU1").Value
Ark4.Range("F5").Value = Sheets(Sheets.Count).Range("AU2").Value
Ark4.Range("G5").Value = Sheets(Sheets.Count).Range("AU3").Value
Ark4.Range("H5").Value = Sheets(Sheets.Count).Range("AV1").Value
Ark4.Range("I5").Value = Sheets(Sheets.Count).Range("AV2").Value
Ark4.Range("J5").Value = Sheets(Sheets.Count).Range("AV3").Value
Ark4.Range("L4").Value = Sheets(Sheets.Count).Range("AP3").Value
Ark4.Range("L5").Value = Sheets(Sheets.Count).Range("AP4").Value
Ark4.Range("L6").Value = Sheets(Sheets.Count).Range("AP5").Value
Ark4.Range("M4").Value = Sheets(Sheets.Count).Range("AQ3").Value
Ark4.Range("M5").Value = Sheets(Sheets.Count).Range("AQ4").Value
Ark4.Range("M6").Value = Sheets(Sheets.Count).Range("AQ5").Value
Ark4.Range("N4").Value = Sheets(Sheets.Count).Range("AR3").Value
Ark4.Range("N5").Value = Sheets(Sheets.Count).Range("AR4").Value
Ark4.Range("N6").Value = Sheets(Sheets.Count).Range("AR5").Value
Ark4.Range("O4").Value = Sheets(Sheets.Count).Range("AS3").Value
Ark4.Range("O5").Value = Sheets(Sheets.Count).Range("AS4").Value
Ark4.Range("O6").Value = Sheets(Sheets.Count).Range("AS5").Value
Ark4.Range("Q4").Value = Sheets(Sheets.Count).Range("AP10").Value
Ark4.Range("Q5").Value = Sheets(Sheets.Count).Range("AP11").Value
Ark4.Range("Q6").Value = Sheets(Sheets.Count).Range("AP12").Value
Ark4.Range("R4").Value = Sheets(Sheets.Count).Range("AQ10").Value
Ark4.Range("R5").Value = Sheets(Sheets.Count).Range("AQ11").Value
Ark4.Range("R6").Value = Sheets(Sheets.Count).Range("AQ12").Value
Ark4.Range("S4").Value = Sheets(Sheets.Count).Range("AR10").Value
Ark4.Range("S5").Value = Sheets(Sheets.Count).Range("AR11").Value
Ark4.Range("S6").Value = Sheets(Sheets.Count).Range("AR12").Value
Ark4.Range("T4").Value = Sheets(Sheets.Count).Range("AS10").Value
Ark4.Range("T5").Value = Sheets(Sheets.Count).Range("AS11").Value
Ark4.Range("T6").Value = Sheets(Sheets.Count).Range("AS12").Value
Ark4.Range("U5").Value = Sheets(Sheets.Count).Range("AW4").Value
Ark4.Range("V5").Value = Sheets(Sheets.Count).Range("AW3").Value
End If
'******* I Want to avoid copying the above code 50 times *******
Application.ScreenUpdating = True
End Sub
The Portfolio report look like this:
The data sheet to build the report from look like this:

Try,
Sub test()
Dim wsData As Worksheet
Dim Ws As Worksheet
Dim vDB As Variant
Dim vR() As Variant
Dim Ark4 As Worksheet
Dim i As Long, n As Long, r As Long
Set Ark4 = Sheets(1) ' set your sheets
Set wsData = Sheets(Sheets.Count)
With wsData
r = .Range("BG" & Rows.Count).End(xlUp).Row + 11
vDB = .Range("ap1", "bh" & r)
End With
For i = 1 To r Step 12
If vDB(i, 18) <> "" Then
n = n + 3
ReDim Preserve vR(1 To 21, 1 To n)
'Column b ~ j
vR(1, n - 2) = vDB(i, 18) 'bg1
vR(2, n - 2) = vDB(i, 17) 'bf1
vR(3, n - 2) = vDB(i, 19)
vR(4, n - 2) = vDB(i, 6)
vR(5, n - 2) = vDB(i + 1, 6)
vR(6, n - 2) = vDB(i + 2, 6)
vR(7, n - 2) = vDB(i, 7)
vR(8, n - 2) = vDB(i + 1, 7)
vR(9, n - 2) = vDB(i + 2, 7)
'Column k ~ o
vR(10, n - 2) = "Budget"
vR(10, n - 1) = "Installemnt"
vR(10, n) = "Deviation"
vR(11, n - 2) = vDB(i + 2, 1) 'ap3
vR(11, n - 1) = vDB(i + 3, 1) 'ap4
vR(11, n) = vDB(i + 4, 1) 'ap5
vR(12, n - 2) = vDB(i + 2, 2) 'aq3
vR(12, n - 1) = vDB(i + 3, 2) 'aq4
vR(12, n) = vDB(i + 4, 2) 'aq5
vR(13, n - 2) = vDB(i + 2, 3) 'ar3
vR(13, n - 1) = vDB(i + 3, 3) 'ar4
vR(13, n) = vDB(i + 4, 3) 'ar5
vR(14, n - 2) = vDB(i + 2, 4) 'as3
vR(14, n - 1) = vDB(i + 3, 4) 'as4
vR(14, n) = vDB(i + 4, 4) 'as5
'Column p ~ z
vR(15, n - 2) = "Budget"
vR(15, n - 1) = "Installemnt"
vR(15, n) = "Deviation"
vR(16, n - 2) = vDB(i + 9, 1) 'ap10
vR(16, n - 1) = vDB(i + 10, 1) 'ap11
vR(16, n) = vDB(i + 11, 1) 'ap12
vR(17, n - 2) = vDB(i + 9, 2) 'aq10
vR(17, n - 1) = vDB(i + 10, 2) 'aq11
vR(17, n) = vDB(i + 11, 2) 'aq12
vR(18, n - 2) = vDB(i + 9, 3) 'ar10
vR(18, n - 1) = vDB(i + 10, 3) 'ar11
vR(18, n) = vDB(i + 11, 3) 'ar12
vR(19, n - 2) = vDB(i + 9, 4) 'as10
vR(19, n - 1) = vDB(i + 10, 4) 'as11
vR(19, n) = vDB(i + 11, 4) 'as12
'Column u,v
vR(20, n - 2) = vDB(i + 3, 8) 'aw4
vR(21, n - 2) = vDB(i + 2, 8) 'aw3
End If
Next i
With Ark4
.Range("b4").Resize(n, 21) = WorksheetFunction.Transpose(vR)
End With
End Sub
It is assumed that the data in the data sheet is repeated as shown in the following figure.

Inefficient excel code breaks after few thousand lines of data

I am fairly new to Excel and VBA. I wrote a code that separates a line of data into multiple sections which then adds headers, colors, and plots.
The problem is when I have many lines of data. My code runs just fine when I have about 4000 lines of data, but I get say about 10000 lines, Excel freezes and does not respond anymore. The code is fairly long and I do expect anyone to read the entire thing.
My doubts are that excel does not respond and crashes because there is a watch-dog timer that times the execution of the code and if it does not receive anything back then it crashes. This is only a guess.
Here is a few lines of the actual data that I need to filter and everything.
2017:06:29T14:12:11,0,1013,00,156,-0.112,12.751,000,000,38,34,33,1014,00,202,-0.102,12.734,000,000,38,35,33,1015,00,174,-0.105,12.755,000,000,37,35,33,1008,00,156,-0.110,12.741,000,000,37,35,33,
2017:06:29T14:12:12,0,1013,00,157,-0.102,12.758,000,000,38,34,33,1014,00,203,-0.105,12.744,000,000,38,35,33,1015,00,175,-0.103,12.757,000,000,37,35,33,1008,00,157,-0.107,12.757,000,000,37,35,33,
2017:06:29T14:12:13,0,1013,00,158,-0.113,12.737,000,000,38,34,33,1014,00,204,-0.094,12.760,000,000,38,35,33,1015,00,176,-0.117,12.748,000,000,37,35,33,1008,00,158,-0.109,12.744,000,000,37,35,33,
2017:06:29T14:12:14,0,1013,00,159,-0.103,12.753,000,000,38,34,33,1014,00,205,-0.103,12.720,000,000,38,35,33,1015,00,177,-0.108,12.732,000,000,37,35,33,1008,00,159,-0.110,12.758,000,000,37,35,33,
2017:06:29T14:12:15,0,1013,00,160,-0.112,12.757,000,000,38,34,33,1014,00,206,-0.095,12.734,000,000,38,35,33,1015,00,178,-0.118,12.729,000,000,37,35,33,1008,00,160,-0.115,12.755,000,000,37,35,33,
I am open to any suggestions and more than happy to learn. Thank you for your time and help in advance.
Sub SeparateData()
'Author: Me
'Date: July 13, 2017
'Purpose: This macro take the data in the worksheet and separates the data in a readable fashion for the user.
' This macro also plots and reports any errors that it has caught both in separate sheets named accordingly.
'Define variables
Dim i As Variant
Dim j As Variant
Dim k As Variant
Dim data As Variant
Dim data2 As Variant
Dim count As Variant
Dim shiftDown As Variant
Dim monitorNum As Variant
Dim errorCount As Variant
Dim battChart As ChartObject
Dim currChart As ChartObject
Dim tempChart As ChartObject
'Stop the alerts so we can erase the sheets peacefully
Application.DisplayAlerts = False
'Erase the extra sheets
Sheets("Sheet2").Delete
Sheets("Sheet3").Delete
'Turn on the alerts in case something else happened
Application.DisplayAlerts = True
'Rename the first sheet
ActiveSheet.Name = "Data"
'Create a new sheet for the plots
Sheets.Add.Name = "Plots"
'Create a new sheet for the errors
Sheets.Add.Name = "Errors"
'Activate the first sheet for data processing
Worksheets("Data").Activate
'Enter the number of monitors
monitorNum = 4
'Variable to shift down the data so that te headers will fit (recommended 2)
shiftDown = 2
'Variable to count the number of errors the program thinks occured
errorCount = 0
'Count how many data point there are in the sheet
count = Cells(1, 1).CurrentRegion.Rows.count
'Iterate through the points separating the Data
For i = 0 To count - 1
'First separate the date from the rest
data = Cells(count - i, 1).Value
data = Split(data, "T")
For j = 0 To UBound(data)
Cells(count - i + shiftDown, j + 1).Value = data(j)
Next j
'Now separate the rest of the data
data2 = data(1)
data2 = Split(data2, ",")
For j = 0 To UBound(data2)
Cells(count - i + shiftDown, j + 2).Value = data2(j)
Next j
For k = 0 To monitorNum - 1
'Check for voltage error
If Cells(count - i + shiftDown, (k * 10) + 8).Value > 20 Or IsNumeric(Cells(count - i + shiftDown, (k * 10) + 8).Value) = False Then
'increment the number of errors found
errorCount = errorCount + 1
'Activate the Errors sheet for error recording
Worksheets("Errors").Activate
'Save the row number and the monitor number where the error was founf
Cells(errorCount, 1).Value = "Voltage error in row"
Cells(errorCount, 2).Value = count - i + shiftDown
Cells(errorCount, 3).Value = "in column"
Cells(errorCount, 4).Value = (k * 10) + 8
Cells(errorCount, 5).Value = "in Monitor"
Cells(errorCount, 6).Value = k + 1
Cells(errorCount, 7).Value = "The recorded data was"
Sheets("Data").Cells(count - i + shiftDown, (k * 10) + 8).Copy Cells(errorCount, 8)
'Autofit all the columns
Cells(1, 1).CurrentRegion.EntireColumn.AutoFit
'Activate the first sheet for data processing
Worksheets("Data").Activate
'Clear the contents of the error
Cells(count - i + shiftDown, (k * 10) + 8).ClearContents
End If
'Check for current error
If Cells(count - i + shiftDown, (k * 10) + 7).Value > 80 Or IsNumeric(Cells(count - i + shiftDown, (k * 10) + 7).Value) = False Then
'increment the number of errors found
errorCount = errorCount + 1
'Activate the Errors sheet for error recording
Worksheets("Errors").Activate
'Save the row number and the monitor number where the error was founf
Cells(errorCount, 1).Value = "Current error in row"
Cells(errorCount, 2).Value = count - i + shiftDown
Cells(errorCount, 3).Value = "in column"
Cells(errorCount, 4).Value = (k * 10) + 7
Cells(errorCount, 5).Value = "in Monitor"
Cells(errorCount, 6).Value = k + 1
Cells(errorCount, 7).Value = "The recorded data was"
Sheets("Data").Cells(count - i + shiftDown, (k * 10) + 7).Copy Cells(errorCount, 8)
'Autofit all the columns
Cells(1, 1).CurrentRegion.EntireColumn.AutoFit
'Activate the first sheet for data processing
Worksheets("Data").Activate
'Clear the contents of the error
Cells(count - i + shiftDown, (k * 10) + 7).ClearContents
End If
'Check for temperature error
If Cells(count - i + shiftDown, (k * 10) + 13).Value > 80 Or IsNumeric(Cells(count - i + shiftDown, (k * 10) + 13).Value) = False Then
'increment the number of errors found
errorCount = errorCount + 1
'Activate the Errors sheet for error recording
Worksheets("Errors").Activate
'Save the row number and the monitor number where the error was founf
Cells(errorCount, 1).Value = "Temperature error in row"
Cells(errorCount, 2).Value = count - i + shiftDown
Cells(errorCount, 3).Value = "in column"
Cells(errorCount, 4).Value = (k * 10) + 13
Cells(errorCount, 5).Value = "in Monitor"
Cells(errorCount, 6).Value = k + 1
Cells(errorCount, 7).Value = "The recorded data was"
Sheets("Data").Cells(count - i + shiftDown, (k * 10) + 13).Copy Cells(errorCount, 8)
'Autofit all the columns
Cells(1, 1).CurrentRegion.EntireColumn.AutoFit
'Activate the first sheet for data processing
Worksheets("Data").Activate
'Clear the contents of the error
Cells(count - i + shiftDown, (k * 10) + 13).ClearContents
End If
Next k
Next i
'Erase the data that has been duplicated
For i = 1 To shiftDown
Cells(i, 1).Value = ""
Next i
'Write and color the headers
'For the Date
Range(Cells(shiftDown - 1, 1), Cells(shiftDown, 1)).Merge
Range(Cells(shiftDown - 1, 1), Cells(shiftDown, 1)).Value = "Date"
Range(Cells(shiftDown - 1, 1), Cells(count + shiftDown, 1)).Interior.Color = RGB(200, 190, 150)
'For the Time
Range(Cells(shiftDown - 1, 2), Cells(shiftDown, 2)).Merge
Range(Cells(shiftDown - 1, 2), Cells(shiftDown, 2)).Value = "Time"
Range(Cells(shiftDown - 1, 2), Cells(count + shiftDown, 2)).Interior.Color = RGB(150, 140, 80)
'For the Key Switch
Range(Cells(shiftDown - 1, 3), Cells(shiftDown, 3)).Merge
Range(Cells(shiftDown - 1, 3), Cells(shiftDown, 3)).Value = "Key Switch"
Range(Cells(shiftDown - 1, 3), Cells(count + shiftDown, 3)).Interior.Color = RGB(200, 200, 0)
For i = 1 To monitorNum
Range(Cells(shiftDown - 1, ((i - 1) * 10) + 4), Cells(shiftDown - 1, (i * 10) + 3)).Merge
Range(Cells(shiftDown - 1, ((i - 1) * 10) + 4), Cells(shiftDown - 1, (i * 10) + 3)).Value = "Monitor " & i
'color the headers
If i Mod 4 = 0 Then
Range(Cells(shiftDown - 1, ((i - 1) * 10) + 4), Cells(shiftDown - 1, (i * 10) + 3)).Interior.Color = RGB(100, 255, 100)
ElseIf i Mod 3 = 0 Then
Range(Cells(shiftDown - 1, ((i - 1) * 10) + 4), Cells(shiftDown - 1, (i * 10) + 3)).Interior.Color = RGB(255, 100, 10)
ElseIf i Mod 2 = 0 Then
Range(Cells(shiftDown - 1, ((i - 1) * 10) + 4), Cells(shiftDown - 1, (i * 10) + 3)).Interior.Color = RGB(100, 100, 255)
Else
Range(Cells(shiftDown - 1, ((i - 1) * 10) + 4), Cells(shiftDown - 1, (i * 10) + 3)).Interior.Color = RGB(255, 75, 75)
End If
Next i
For i = 0 To monitorNum - 1
'Monitor ID
Cells(shiftDown, 1 + (i * 10) + 3).Value = "MONITOR_NUM"
'Monitor status
Cells(shiftDown, 2 + (i * 10) + 3).Value = "MONITOR_STATUS"
'Heart Beat count
Cells(shiftDown, 3 + (i * 10) + 3).Value = "HB_COUNT"
'For Current
Cells(shiftDown, 4 + (i * 10) + 3).Value = "CURRENT"
Range(Cells(shiftDown, 4 + (i * 10) + 3), Cells(count + shiftDown, 4 + (i * 10) + 3)).Interior.Color = RGB(240, 150, 150)
'For Voltage
Cells(shiftDown, 5 + (i * 10) + 3).Value = "VOLTAGE"
Range(Cells(shiftDown, 5 + (i * 10) + 3), Cells(count + shiftDown, 5 + (i * 10) + 3)).Interior.Color = RGB(110, 160, 180)
'State of Charge
Cells(shiftDown, 6 + (i * 10) + 3).Value = "SOC"
'State of Health
Cells(shiftDown, 7 + (i * 10) + 3).Value = "SOH"
'Chip temperature
Cells(shiftDown, 8 + (i * 10) + 3).Value = "TEMP_CHP"
'Internal temperature
Cells(shiftDown, 9 + (i * 10) + 3).Value = "TEMP_INT"
'For Temperature of the terminal
Cells(shiftDown, 10 + (i * 10) + 3).Value = "TEMP_EXT"
Range(Cells(shiftDown, 10 + (i * 10) + 3), Cells(count + shiftDown, 10 + (i * 10) + 3)).Interior.Color = RGB(255, 190, 0)
Next i
'Add borders all around the data
Cells(shiftDown, 1).CurrentRegion.Borders.LineStyle = xlContinuous
'Autofit all the columns
Cells(shiftDown, 1).CurrentRegion.EntireColumn.AutoFit
'Plotting
'Activate the first sheet for data plotting
Worksheets("Data").Activate
'Add a new plot
Set battChart = Sheets("Plots").ChartObjects.Add(0, 0, 1200, 300)
'Plot the battery data
With battChart.Chart
.SetSourceData Source:=Sheets("Data").Range(Cells(5, 8), Cells(count + shiftDown, 8))
.SeriesCollection(1).Name = "Battery 1"
.ChartWizard Title:="Voltage", HasLegend:=True, CategoryTitle:="Time (s)", ValueTitle:="Voltage (V)", Gallery:=xlXYScatterLinesNoMarkers
For i = 2 To monitorNum
.SeriesCollection.NewSeries
.SeriesCollection(i).Values = Sheets("Data").Range(Cells(5, ((i - 1) * 10) + 8), Cells(count + shiftDown, ((i - 1) * 10) + 8))
.SeriesCollection(i).Name = "Battery " & i
Next i
End With
'Add a new plot
Set currChart = Sheets("Plots").ChartObjects.Add(0, 300, 1200, 300)
'Plot the current data
With currChart.Chart
.SetSourceData Source:=Sheets("Data").Range(Cells(5, 7), Cells(count + shiftDown, 7))
.SeriesCollection(1).Name = "Battery 1"
.ChartWizard Title:="Current", HasLegend:=True, CategoryTitle:="Time (s)", ValueTitle:="Current (A)", Gallery:=xlXYScatterLinesNoMarkers
For i = 2 To monitorNum
.SeriesCollection.NewSeries
.SeriesCollection(i).Values = Sheets("Data").Range(Cells(5, ((i - 1) * 10) + 7), Cells(count + shiftDown, ((i - 1) * 10) + 7))
.SeriesCollection(i).Name = "Battery " & i
Next i
End With
'Add a new plot
Set tempChart = Sheets("Plots").ChartObjects.Add(0, 600, 1200, 300)
'Plot the current data
With tempChart.Chart
.SetSourceData Source:=Sheets("Data").Range(Cells(5, 13), Cells(count + shiftDown, 13))
.SeriesCollection(1).Name = "Battery 1"
.ChartWizard Title:="Temperature", HasLegend:=True, CategoryTitle:="Time (s)", ValueTitle:="Temperature (F)", Gallery:=xlXYScatterLinesNoMarkers
For i = 2 To monitorNum
.SeriesCollection.NewSeries
.SeriesCollection(i).Values = Sheets("Data").Range(Cells(5, ((i - 1) * 10) + 13), Cells(count + shiftDown, ((i - 1) * 10) + 13))
.SeriesCollection(i).Name = "Battery " & i
Next i
End With
'Indicate that the macro has finished its job
Beep
MsgBox "Data separation is complete. There were " & errorCount & " errors found."
End Sub

All of your Worksheets("x").Activate are totally unnecessary, are slowing your code significantly and are begging for inexplicable errors later when you forget to activate the correct sheet or your bored user starts clicking around during execution because it's taking too long. Declare some Worksheet variables and work with those.
Dim DataSheet as Worksheet
ActiveSheet.Name = "Data"
Set DataSheet = ActiveSheet
Dim PlotSheet as Worksheet
Set PlotSheet as Worksheets.Add
Plotsheet.Name = "Plots"
Dim ErrorSheet as Worksheet
Set ErrorSheet = Worksheets.Add
ErrorSheet.Name = "Errors"
count = Datasheet.Cells(1, 1).CurrentRegion.Rows.count
'GET RID OF THIS EVERYWHERE!!! Worksheets("Errors").Activate
'Save the row number and the monitor number where the error was founf
With ErrorSheet
.Cells(errorCount, 1).Value = "Voltage error in row"
.Cells(errorCount, 2).Value = count - i + shiftDown
.Cells(errorCount, 3).Value = "in column"
.Cells(errorCount, 4).Value = (k * 10) + 8
.Cells(errorCount, 5).Value = "in Monitor"
.Cells(errorCount, 6).Value = k + 1
.Cells(errorCount, 7).Value = "The recorded data was"
'Note subtle change here:
DataSheet.Cells(count - i + shiftDown, (k * 10) + 8).Copy .Cells(errorCount, 8)
'Note: explicitly setting "datasheet" as the destination and using the "With" to save some typing on the ".Cells" call.
'You could explicitly type the "ErrorSheet" to make it more clear
'an even better version is:
.cells(errorCount, 8) = DataSheet.Cells(count - i + shiftDown, (k * 10) + 8)
End With
Continue to do that everywhere. Future you will appreciate current you...
Every time you're doing a Sheet("x").Activate eliminate that line and explicitly add a reference to the appropriate worksheet variable you declared earlier.
Every time you have an unqualified Sheets or Cells or Range call, make it an explicit reference by prepending the appropriate worksheet variable. Future you will appreciate the fact that you can see exactly what worksheet you're referencing. Sure, there may be some extra typing involved, but that extra typing significantly reduces the chance of inserting very subtle and difficult to find bugs.
Using .Copy is very slow for single cells. It does gain a speed advantage if you're copying large blocks of cells in a single go (somewhere in the neighborhood of 3-5k cells in a single copy statement vs a loop through setting individual cell values).
As Uri Goren pointed out setting Application.Calculation = False will definitely improve your speed. I'd recommend not setting Application.ScreenUpdating = False until after your code is 100% functional and not generating any errors. Once you're at that point, it's a great thing to do.
At this point in your code you may want to add the indicated line:
'Iterate through the points separating the Data
For i = 0 To count - 1
'Add this line:
Application.StatusBar = "Separating points #" & i
Put a similar message just inside the top of each of your large loops. You'll likely see that your code isn't hanging, just taking a long time to process. Plus you'll have an update that your user can watch so (s)he'll know it isn't hung and is still doing something.
At the end of your code put:
Application.StatusBar = ""
To clear the message so you get your normal Excel StatusBar functionality returned.

Add these two lines at the beginning of the subroutine:
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
And these 2 lines before the end of the subroutine
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
It should speed up your code significantly

Excel VBA - Merging cells based on duplicates search

I need help writing a VBA code to find duplicate values in one column and then merge cells based off that search.
E.g:
France 6216 EDE 009789 Company A
France 6216 EDF 009790 Company A
France 6216 EDG 009791 Company A
Germany 6216 EDH 009792 Company B
Becomes:
France 6216 EDE EDF EDG 009789 009790 009791 Company A
Germany 6216 EDH 009792 Company B
Its on a large spreadsheet where some dupes will have two but some could be as many as eight.
Can anyone help me?
Any questions please let me know.
Thanks so much!

Try out this macro,
Sub removeDupes()
Dim i As Long, j As Long, k As Long
Columns("A:E").Sort key1:=Range("A2"), order1:=xlAscending, Header:=xlYes
Sheets.Add.Name = "newSheet"
Sheets("newSheet").Cells(1, 1) = Cells(2, 1)
Sheets("newSheet").Cells(1, 2) = Cells(2, 2)
Sheets("newSheet").Cells(1, 3) = Cells(2, 3)
Sheets("newSheet").Cells(1, 150) = Cells(2, 4)
Sheets("newSheet").Cells(1, 255) = Cells(2, 5)
j = 1
k = 1
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i + 1, 1) = Cells(i, 1) Then
Sheets("newSheet").Cells(j, 3 + k) = Cells(i + 1, 3)
Sheets("newSheet").Cells(j, 150 + k) = Cells(i + 1, 4)
k = k + 1
Else
j = j + 1
Sheets("newSheet").Cells(j, 1) = Cells(i + 1, 1)
Sheets("newSheet").Cells(j, 2) = Cells(i + 1, 2)
Sheets("newSheet").Cells(j, 3) = Cells(i + 1, 3)
Sheets("newSheet").Cells(j, 150) = Cells(i + 1, 4)
Sheets("newSheet").Cells(j, 255) = Cells(i + 1, 5)
k = 1
End If
Next i
For i = 255 To 1 Step -1
If Sheets("newSheet").Cells(1, i) = "" Then
Sheets("newSheet").Columns(i).Delete
End If
Next i
End Sub
Source:
Output:

Resources